diff -Nru racket-7.2+ppa2/collects/compiler/embed.rkt racket-7.3+ppa1/collects/compiler/embed.rkt --- racket-7.2+ppa2/collects/compiler/embed.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/compiler/embed.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -405,7 +405,10 @@ (extract-last (unix-style-split s)))]) (let ([p (build-path collects-dest (apply build-path dir) - "compiled" + (let ([l (use-compiled-file-paths)]) + (if (pair? l) + (car l) + "compiled")) (path-add-extension file #".zo"))]) (let-values ([(base name dir?) (split-path p)]) (make-directory* base) @@ -540,12 +543,6 @@ ;; check for run-time paths by visiting the module in an ;; expand-time namespace: (parameterize ([current-namespace expand-namespace]) - (define no-submodule-code - ;; Strip away submodules to avoid re-declaring them: - (module-compiled-submodules - (module-compiled-submodules code #f null) - #t - null)) (let ([module-path (if (path? module-path) (path->complete-path module-path) @@ -555,7 +552,7 @@ (module-path-index-resolve (module-path-index-join module-path #f))]) - (eval no-submodule-code))) + (eval code))) (define e (expand `(,#'module m racket/kernel (#%require (only ,module-path) racket/runtime-path) @@ -1527,6 +1524,7 @@ dest mred?)))))) (define embed-dlls? (and (eq? 'windows (cross-system-type)) + (eq? 'racket (cross-system-type 'vm)) (let ([m (assq 'embed-dlls? aux)]) (and m (cdr m))))) (define embedded-dlls-box (and embed-dlls? (box null))) diff -Nru racket-7.2+ppa2/collects/compiler/private/cm-minimal.rkt racket-7.3+ppa1/collects/compiler/private/cm-minimal.rkt --- racket-7.2+ppa2/collects/compiler/private/cm-minimal.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/compiler/private/cm-minimal.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -17,6 +17,7 @@ managed-compile-zo make-caching-managed-compile-zo trust-existing-zos + managed-recompile-only manager-compile-notify-handler manager-skip-file-handler manager-trace-handler @@ -55,6 +56,7 @@ (define manager-trace-handler (make-parameter default-manager-trace-handler)) (define indent (make-parameter 0)) (define trust-existing-zos (make-parameter #f)) +(define managed-recompile-only (make-parameter #f)) (define manager-skip-file-handler (make-parameter (λ (x) #f))) (define depth (make-parameter 0)) (define parallel-lock-client (make-parameter #f)) @@ -156,7 +158,7 @@ (and (pair? p) (cdr p))) (define deps-imports cdddr) -(define (get-compilation-path path->mode roots path) +(define (get-compilation-path path->mode roots path #:for-lock? [for-lock? #f]) (let-values ([(dir name) (get-compilation-dir+name path #:modes (list (path->mode path)) #:roots roots @@ -165,7 +167,8 @@ ;; may pick the first root where there's no ".dep" ;; written yet when the second root on has a ".dep" ;; and the ".zo" is not yet in place - #:default-root (if (cross-multi-compile? roots) + #:default-root (if (and (not for-lock?) + (cross-multi-compile? roots)) (cadr roots) (car roots)))]) (build-path dir name))) @@ -370,6 +373,11 @@ #:recompile-from recompile-from #:assume-compiled-sha1 assume-compiled-sha1 #:use-existing-deps use-existing-deps) + (when (and (not recompile-from) + (managed-recompile-only)) + (error 'compile-zo + "compile from source disallowed\n module: ~a" + path)) (cond [(cross-multi-compile? roots) (define running-root (car roots)) @@ -494,7 +502,9 @@ [(and (equal? recompile-from zo-name) (not (current-compile-target-machine))) ;; We don't actually need to do anything, so - ;; avoid updating the file + ;; avoid updating the file. + (check-recompile-module-dependencies use-existing-deps + collection-cache) #f] [recompile-from (recompile-module-code recompile-from @@ -590,13 +600,7 @@ zo-name) (define (recompile-module-code recompile-from src-path deps collection-cache) - ;; Force potential recompilation of dependencies. Otherwise, we - ;; end up relying on cross-module optimization demands, which might - ;; not happen and are unlikely to cover everything. - (for ([d (in-list (deps-imports deps))] - #:unless (external-dep? d)) - (define path (collects-relative*->path (dep->encoded-path d) collection-cache)) - (module-path-index-resolve (module-path-index-join path #f) #t)) + (check-recompile-module-dependencies deps collection-cache) ;; Recompile the module: (define-values (base name dir?) (split-path src-path)) (parameterize ([current-load-relative-directory @@ -605,6 +609,15 @@ (call-with-input-file* recompile-from read))) (compiled-expression-recompile code))) +;; Force potential recompilation of dependencies. Otherwise, we +;; end up relying on cross-module optimization demands, which might +;; not happen and are unlikely to cover everything. +(define (check-recompile-module-dependencies deps collection-cache) + (for ([d (in-list (deps-imports deps))] + #:unless (external-dep? d)) + (define path (collects-relative*->path (dep->encoded-path d) collection-cache)) + (module-path-index-resolve (module-path-index-join path #f) #t))) + (define (install-module-hashes! s [start 0] [len (bytes-length s)]) (define vlen (bytes-ref s (+ start 2))) (define vmlen (bytes-ref s (+ start 3 vlen))) @@ -690,15 +703,21 @@ (touch zo-name) #f] [else + (define lock-zo-name (if (cross-multi-compile? roots) + ;; Make sure we use a file path for the lock that is consistent + ;; with being in a phase of compiling for the current machine: + (path-add-extension (get-compilation-path path->mode roots path) #".zo") + zo-name)) ;; Called when `tryng-sha1?` is #f and this process (or some process) ;; needs to compile, recompile, or touch: (define (build #:just-touch? [just-touch? #f] #:recompile-from [recompile-from #f] + #:recompile-from-machine [recompile-from-machine #f] #:assume-compiled-sha1 [assume-compiled-sha1 #f] #:use-existing-deps [use-existing-deps #f]) (define lc (parallel-lock-client)) (when lc (log-compile-event path 'locking)) - (define locked? (and lc (lc 'lock zo-name))) + (define locked? (and lc (lc 'lock lock-zo-name))) (define ok-to-compile? (or (not lc) locked?)) (dynamic-wind (lambda () (void)) @@ -710,8 +729,16 @@ (touch zo-name)] [else (when just-touch? (set! just-touch? #f)) - (log-compile-event path (if recompile-from 'start-recompile 'start-compile)) - (trace-printf "~acompiling ~a" (if recompile-from "re" "") actual-path) + (define mi-recompile-from (select-machine-independent recompile-from + recompile-from-machine + path + roots + path->mode)) + (define recompile-from-exists? (and mi-recompile-from + ;; Checking existence now after taking lock: + (file-exists? mi-recompile-from))) + (trace-printf "~acompiling ~a" (if recompile-from-exists? "re" "") actual-path) + (log-compile-event path (if recompile-from-exists? 'start-recompile 'start-compile)) (parameterize ([depth (+ (depth) 1)]) (with-handlers ([exn:get-module-code? (lambda (ex) @@ -719,17 +746,14 @@ (exn:get-module-code-path ex) (exn-message ex)) (raise ex))]) - (define recompile-from-exists? (and recompile-from - ;; Checking existence now after taking lock: - (file-exists? recompile-from))) (compile-zo*/cross-compile path->mode roots path src-sha1 read-src-syntax zo-name up-to-date collection-cache #:recompile-from (and recompile-from-exists? - recompile-from) + mi-recompile-from) #:assume-compiled-sha1 (and recompile-from-exists? (force assume-compiled-sha1)) #:use-existing-deps (and recompile-from-exists? use-existing-deps)))) - (trace-printf "~acompiled ~a" (if recompile-from "re" "") actual-path)]))) + (trace-printf "~acompiled ~a" (if recompile-from-exists? "re" "") actual-path)]))) (lambda () (log-compile-event path (if (or (not lc) locked?) (cond @@ -738,12 +762,13 @@ [else 'finish-compile]) 'already-done)) (when locked? - (lc 'unlock zo-name)))) + (lc 'unlock lock-zo-name)))) #f) ;; Called to recompile bytecode that is currently in ;; machine-independent form: - (define (build/recompile) + (define (build/recompile zo-name-machine) (build #:recompile-from zo-name + #:recompile-from-machine zo-name-machine #:assume-compiled-sha1 (or (deps-assume-compiled-sha1 deps) ;; delay until lock is held: (delay (call-with-input-file* zo-name sha1))) @@ -757,8 +782,8 @@ (define (build/sync) (define lc (parallel-lock-client)) (when lc - (when (lc 'lock zo-name) - (lc 'unlock zo-name))) + (when (lc 'lock lock-zo-name) + (lc 'unlock lock-zo-name))) #f) ;; ---------------------------------------- ;; Determine whether and how to rebuild the file: @@ -780,7 +805,7 @@ ;; so we don't need to rebuild if just looking for the hash. (cond [trying-sha1? #f] - [else (build/recompile)])] + [else (build/recompile (deps-machine deps))])] [else ;; No need to build (cond @@ -828,7 +853,7 @@ ;; that module will cause this one to be recompiled (i.e., back here ;; with `trying-sha1?` as #f) #f] - [else (build/recompile)])])] + [else (build/recompile (deps-machine deps))])])] [trying-sha1? ;; Needs to be built, but we can't build now #t] @@ -840,9 +865,10 @@ (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)))) + (or (and (eq? 'racket (system-type 'vm)) + (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"))))) ;; Gets a multi-sha1 string that represents the compiled code @@ -895,11 +921,12 @@ (cadr roots) (car 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 - roots) + (or (and (eq? 'racket (system-type 'vm)) + (try-file-sha1 (build-path dir "native" (system-library-subpath) + (path-add-extension name (system-type + 'so-suffix))) + dep-path + roots)) (try-file-sha1 (build-path dir (path-add-extension name #".zo")) dep-path roots) @@ -927,14 +954,8 @@ #:sha1-only? [sha1-only? #f]) (define orig-path (simple-form-path path0)) (define (read-deps path) - (with-handlers ([exn:fail:filesystem? (lambda (ex) - (trace-printf "failed reading ~a" path) - (list #f "none" '(#f . #f)))]) - (with-module-reading-parameterization - (lambda () - (call-with-input-file* - (path-add-extension (get-compilation-path path->mode roots path) #".dep") - read))))) + (read-deps-file + (path-add-extension (get-compilation-path path->mode roots path) #".dep"))) (define (do-check) (let* ([main-path orig-path] [alt-path (rkt->ss orig-path)] @@ -1063,6 +1084,38 @@ (trace-printf "checking: ~a" orig-path) (do-check)]))) +(define (read-deps-file dep-path) + (with-handlers ([exn:fail:filesystem? (lambda (ex) + (trace-printf "failed reading ~a" dep-path) + (list #f "none" '(#f . #f)))]) + (with-module-reading-parameterization + (lambda () + (call-with-input-file* dep-path read))))) + +;; Make sure `recompile-from` is machine-independent so that +;; recompilation makes sense. +;; The compilation lock must is held for the source of `recompile-from`. +(define (select-machine-independent recompile-from + recompile-from-machine + path + roots + path->mode) + (cond + [(not recompile-from) #f] + [(not recompile-from-machine) recompile-from] + [(and (pair? roots) (pair? (cdr roots))) + ;; We have a machine-dependent ".zo" file. Maybe we'll + ;; fine a machine-independent version by checking the + ;; last compilation path + (define-values (code-dir code-name) + (get-compilation-dir+name path #:modes (list (path->mode path)) #:roots (list (last roots)))) + (define alt-recompile-from + (build-path code-dir (path-add-suffix code-name #".zo"))) + (define deps (read-deps-file (path-replace-suffix alt-recompile-from #".dep"))) + (and (not (deps-machine deps)) + alt-recompile-from)] + [else #f])) + (define (ormap-strict f l) (cond [(null? l) #f] diff -Nru racket-7.2+ppa2/collects/compiler/private/elf.rkt racket-7.3+ppa1/collects/compiler/private/elf.rkt --- racket-7.2+ppa2/collects/compiler/private/elf.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/compiler/private/elf.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -48,7 +48,7 @@ sh-offset sh-esize sh-ecount class format sh-str-index) #:transparent) -(struct section (name-offset addr offset size type) +(struct section (name-offset addr offset size type alloc?) #:transparent) (struct program (offset vaddr paddr size) #:transparent) @@ -206,7 +206,8 @@ [info (read-word)] [align (read-xword)] [esize (read-xword)]) - (section name-offset addr offset size type)))]) + (define alloc? (bitwise-bit-set? flags 1)) + (section name-offset addr offset size type alloc?)))]) ;; Read program headers ------------------------ (let ([programs (for/list ([i (in-range ph-ecount)]) @@ -253,7 +254,8 @@ (define (find-section-by-offset offset sections) (for/or ([s (in-list sections)]) - (and (offset . >= . (section-offset s)) + (and (section-alloc? s) + (offset . >= . (section-offset s)) (offset . < . (+ (section-offset s) (section-size s))) s))) diff -Nru racket-7.2+ppa2/collects/compiler/private/mach-o.rkt racket-7.3+ppa1/collects/compiler/private/mach-o.rkt --- racket-7.2+ppa2/collects/compiler/private/mach-o.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/compiler/private/mach-o.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -262,8 +262,8 @@ (+ link-edit-addr (round-up-page link-edit-vmlen)))]) (unless ((+ end-cmd new-cmd-sz) . < . min-used) (error 'check-header - "no room for a new section load command (current end is ~a; min used is ~a)" - end-cmd min-used)) + "no room for a new section load command (current end is ~a; min used is ~a; need ~a)" + end-cmd min-used new-cmd-sz)) ;; Shift commands starting with link-edit command: (unless link-edit-pos (error "LINKEDIT not found")) (file-position p link-edit-pos) diff -Nru racket-7.2+ppa2/collects/db/private/generic/sql-data.rkt racket-7.3+ppa1/collects/db/private/generic/sql-data.rkt --- racket-7.2+ppa2/collects/db/private/generic/sql-data.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/db/private/generic/sql-data.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -11,15 +11,23 @@ ;; NULL (define-values (sql-null sql-null?) - (let () + (let ([created? #false]) (struct sql-null () - ;; must deserialize to singleton, so can't just use serializable-struct - #:property prop:serializable - (make-serialize-info (lambda _ '#()) - #'deserialize-info:sql-null-v0 - #f - (or (current-load-relative-directory) - (current-directory)))) + #:transparent + #:authentic + #:guard (lambda (n) + (when created? + (error 'sql-null "cannot create new instances of sql-null")) + (set! created? #true) + (values)) + #:property prop:custom-write (lambda (v p w?) (write-string "#" p)) + ;; must deserialize to singleton, so can't just use serializable-struct + #:property prop:serializable + (make-serialize-info (lambda _ '#()) + #'deserialize-info:sql-null-v0 + #f + (or (current-load-relative-directory) + (current-directory)))) (values (sql-null) sql-null?))) (define (sql-null->false x) diff -Nru racket-7.2+ppa2/collects/ffi/unsafe/alloc.rkt racket-7.3+ppa1/collects/ffi/unsafe/alloc.rkt --- racket-7.2+ppa2/collects/ffi/unsafe/alloc.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/ffi/unsafe/alloc.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -55,61 +55,111 @@ ;; replaced existing allocations/retains. (remove-node! expected-ds)]))) +(define (check-arity-includes-1 who proc [expected "(-> any/c any)"]) + (unless (procedure-arity-includes? proc 1) + (raise-argument-error who expected proc))) + (define ((allocator d) proc) + (check-arity-includes-1 'allocator d) (rename - (lambda args - (call-as-atomic - (lambda () - (let ([v (apply proc args)]) - (when v - (define ds (node (make-late-weak-box v) d #f #f #f)) - (add-node! ds) - (hash-set! allocated v ds) - (register-finalizer v deallocate)) - v)))) - proc)) + (let-values ([(_ allowed-kws) (procedure-keywords proc)]) + (define (register v) + (when v + (define ds (node (make-late-weak-box v) d #f #f #f)) + (add-node! ds) + (hash-set! allocated v ds) + (register-finalizer v deallocate)) + v) + (cond + [(null? allowed-kws) + (lambda args + (call-as-atomic + (lambda () + (register (apply proc args)))))] + [else + (make-keyword-procedure + (λ (kws kw-args . rest) + (call-as-atomic + (lambda () + (register (keyword-apply proc kws kw-args rest))))))])) + proc)) (define ((deallocator [get-arg car]) proc) + (check-arity-includes-1 'deallocator get-arg "(-> list/c any/c)") (rename - (lambda args - (call-as-atomic - (lambda () - (apply proc args) - (let ([v (get-arg args)]) - (let ([ds (hash-ref allocated v #f)]) - (when ds - (remove-node! ds) - (define rest-ds (node-rest ds)) - (if rest-ds - (hash-set! allocated v rest-ds) - (hash-remove! allocated v)))))))) - proc)) + (let-values ([(_ allowed-kws) (procedure-keywords proc)]) + (define (handle v) + (let ([ds (hash-ref allocated v #f)]) + (when ds + (remove-node! ds) + (define rest-ds (node-rest ds)) + (if rest-ds + (hash-set! allocated v rest-ds) + (hash-remove! allocated v))))) + (cond + [(null? allowed-kws) + (lambda args + (call-as-atomic + (lambda () + (begin0 (apply proc args) + (handle (get-arg args))))))] + [else + (make-keyword-procedure + (λ (kws kw-args . rest) + (call-as-atomic + (lambda () + (begin0 + (keyword-apply proc kws kw-args rest) + (handle (get-arg rest)))))))])) + proc)) (define ((retainer d [get-arg car]) proc) + (check-arity-includes-1 'retainer d) + (check-arity-includes-1 'retainer get-arg "(-> list/c any/c)") (rename - (lambda args - (call-as-atomic - (lambda () - (begin0 - (apply proc args) - (let ([v (get-arg args)]) - (define next-ds (hash-ref allocated v #f)) - (define ds (node (make-late-weak-box v) d #f #f next-ds)) - (add-node! ds) - (hash-set! allocated v ds) - (unless next-ds - (register-finalizer v deallocate))))))) + (let-values ([(_ allowed-kws) (procedure-keywords proc)]) + (define (handle v) + (define next-ds (hash-ref allocated v #f)) + (define ds (node (make-late-weak-box v) d #f #f next-ds)) + (add-node! ds) + (hash-set! allocated v ds) + (unless next-ds + (register-finalizer v deallocate))) + (cond + [(null? allowed-kws) + (lambda args + (call-as-atomic + (lambda () + (begin0 (apply proc args) + (handle (get-arg args))))))] + [else + (make-keyword-procedure + (λ (kws kw-args . rest) + (call-as-atomic + (lambda () + (begin0 + (keyword-apply proc kws kw-args rest) + (handle (get-arg rest)))))))])) proc)) + (define (rename new orig) (and orig - (let ([n (object-name orig)] - [new (procedure-reduce-arity - new - (procedure-arity orig))]) - (if n - (procedure-rename new n) - new)))) + (let-values ([(required-kws allowed-kws) (procedure-keywords orig)] + [(arity-mask) (procedure-arity-mask orig)] + [(name) (object-name orig)]) + (cond + [(null? allowed-kws) + (procedure-reduce-arity-mask + new + arity-mask + name)] + [else + (procedure-reduce-keyword-arity-mask + (if name (procedure-rename new name) new) + arity-mask + required-kws + allowed-kws)])))) ;; ---------------------------------------- diff -Nru racket-7.2+ppa2/collects/ffi/unsafe/com.rkt racket-7.3+ppa1/collects/ffi/unsafe/com.rkt --- racket-7.2+ppa2/collects/ffi/unsafe/com.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/ffi/unsafe/com.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -2055,7 +2055,11 @@ (define (follow-chain who obj names len) (for ([s (in-list names)] [i (in-range len)]) - (unless (string? s) (raise-type-error who "string" s))) + (unless (or (string? s) + (and (list? s) + (pair? s) + (string? (car s)))) + (raise-argument-error who "(or/c string? (cons/c string? list?))" s))) (define-values (target-obj release?) (for/fold ([obj obj] [release? #f]) ([i (in-range (sub1 len))] [s (in-list names)]) @@ -2078,7 +2082,7 @@ (string? (car name))) (do-com-invoke 'com-get-property obj (car name) (cdr name) INVOKE_PROPERTYGET)] [else - (raise-argument-error 'com-get-property "(or/c string? (cons/c string? list))" + (raise-argument-error 'com-get-property "(or/c string? (cons/c string? list?))" name)])] [(obj name1 . more-names) (check-com-obj 'com-get-property obj) diff -Nru racket-7.2+ppa2/collects/ffi/unsafe/objc.rkt racket-7.3+ppa1/collects/ffi/unsafe/objc.rkt --- racket-7.2+ppa2/collects/ffi/unsafe/objc.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/ffi/unsafe/objc.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -904,12 +904,10 @@ [(eq? (syntax-e #'id) 'dealloc) ;; so that objects can be destroyed in foreign threads: #'apply-directly] - [(eq? (system-type 'vm) 'chez-scheme) + [else ;; to cooperate with blocking callouts, we need a non-#f - ;; `async-apply` - #'complain-apply-foreign-thread] - [else - #'#f])]) + ;; `async-apply` for CS + #'maybe-complain-apply-foreign-thread])]) (syntax/loc m (kind #:async-apply async result-type (id arg ...) body0 body ...))))] [else (raise-syntax-error #f @@ -919,12 +917,14 @@ (define (apply-directly f) (f)) -(define (complain-apply-foreign-thread f) - ;; We'd like to complain, but we' not in a context where there's a - ;; valid way to complain. Try logging an error, and just maybe that - ;; will get some information out. - (log-error "callback in unexpected thread") - (void)) +(define maybe-complain-apply-foreign-thread + (and (eq? (system-type 'vm) 'chez-scheme) + (lambda (f) + ;; We'd like to complain, but we' not in a context where there's a + ;; valid way to complain. Try logging an error, and just maybe that + ;; will get some information out. + (log-error "callback in unexpected thread") + (void)))) (define methods (make-hasheq)) (define (save-method! m) diff -Nru racket-7.2+ppa2/collects/ffi/unsafe/port.rkt racket-7.3+ppa1/collects/ffi/unsafe/port.rkt --- racket-7.2+ppa2/collects/ffi/unsafe/port.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/ffi/unsafe/port.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -6,4 +6,80 @@ unsafe-socket->port unsafe-port->socket unsafe-socket->semaphore)) -(provide (all-from-out '#%unsafe)) +(provide (all-from-out '#%unsafe) + unsafe-fd->evt) + +(module fd-evt racket/base + (require (only-in '#%unsafe + unsafe-start-atomic + unsafe-end-atomic + unsafe-poller + unsafe-poll-fd + unsafe-poll-ctx-fd-wakeup)) + (provide (protect-out unsafe-fd->evt)) + + (define socket-different? + (case (system-type 'os) + [(windows) #t] + [else #f])) + + (struct fd-evt (sfd mode socket? [closed? #:mutable]) + #:property prop:evt + (unsafe-poller + (lambda (self wakeups) + (define sfd (fd-evt-sfd self)) + (define mode (fd-evt-mode self)) + (define socket? (fd-evt-socket? self)) + (cond + [(fd-evt-closed? self) + (values (list self) #f)] + [(unsafe-poll-fd sfd mode socket?) + (values (list self) #f)] + [else + (when wakeups + (unsafe-poll-ctx-fd-wakeup wakeups sfd mode #;socket?)) + (values #f self)])))) + + ;; {file-descriptor,socket}=>{read,write}-evt : (Hasheqv Nat => fd-evt) + (define file-descriptor=>read-evt (make-hasheqv)) + (define file-descriptor=>write-evt (make-hasheqv)) + (define socket=>read-evt (if socket-different? (make-hasheqv) file-descriptor=>read-evt)) + (define socket=>write-evt (if socket-different? (make-hasheqv) file-descriptor=>write-evt)) + + ;; Differences between unsafe-fd->evt and unsafe-{file-descriptor,socket}->semaphore: + ;; - level-triggered, not edge-triggered + ;; - no cooperation with ports created by unsafe-{file-descriptor,socket}->port + + (define (unsafe-fd->evt sfd mode [socket0? #t]) + (define socket? (and socket0? #t)) + (define sfd=>read-evt (if socket? socket=>read-evt file-descriptor=>read-evt)) + (define sfd=>write-evt (if socket? socket=>write-evt file-descriptor=>write-evt)) + (unless (exact-integer? sfd) + (raise-argument-error 'unsafe-fd->evt "handle-integer?" 0 sfd mode socket0?)) + (unsafe-start-atomic) + (begin0 + (case mode + [(read) (hash-ref! sfd=>read-evt sfd (lambda () (fd-evt sfd mode socket? #f)))] + [(write) (hash-ref! sfd=>write-evt sfd (lambda () (fd-evt sfd mode socket? #f)))] + [(check-read) (hash-ref sfd=>read-evt sfd #f)] + [(check-write) (hash-ref sfd=>write-evt sfd #f)] + [(remove) + (define (remove-and-close sfd=>evt) + (define evt (hash-ref sfd=>evt sfd #f)) + (when evt + (hash-remove! sfd=>evt sfd) + (set-fd-evt-closed?! evt #t))) + (remove-and-close sfd=>read-evt) + (remove-and-close sfd=>write-evt) + #f] + [(internal-debug) + `((read ,(hash-keys sfd=>read-evt)) + (write ,(hash-keys sfd=>write-evt)))] + [else + (unsafe-end-atomic) + (raise-argument-error 'unsafe-fd->evt + "(or/c 'read 'write 'check-read 'check-write 'remove)" + 1 sfd mode socket0?)]) + (unsafe-end-atomic)))) + +(require (submod "." fd-evt)) diff -Nru racket-7.2+ppa2/collects/ffi/unsafe/schedule.rkt racket-7.3+ppa1/collects/ffi/unsafe/schedule.rkt --- racket-7.2+ppa2/collects/ffi/unsafe/schedule.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/ffi/unsafe/schedule.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1,6 +1,7 @@ #lang racket/base (require (only-in '#%unsafe unsafe-poller + unsafe-poll-fd unsafe-poll-ctx-fd-wakeup unsafe-poll-ctx-eventmask-wakeup unsafe-poll-ctx-milliseconds-wakeup diff -Nru racket-7.2+ppa2/collects/file/untar.rkt racket-7.3+ppa1/collects/file/untar.rkt --- racket-7.2+ppa2/collects/file/untar.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/file/untar.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -212,6 +212,12 @@ #f] [else ;; traditional: + (define skip-head + (or (for/or ([i (in-range len)]) + (case (integer->char (bytes-ref bstr i)) + [(#\space #\nul) #f] + [else i])) + (error 'untar "bad number ~e at ~a" bstr (file-position in)))) (define skip-tail (- len (or (for/or ([i (in-range len 0 -1)]) @@ -219,7 +225,7 @@ [(#\space #\nul) #f] [else i])) (error 'untar "bad number ~e at ~a" bstr (file-position in))))) - (for/fold ([v 0]) ([i (in-range (- len skip-tail))]) + (for/fold ([v 0]) ([i (in-range skip-head (- len skip-tail))]) (define b (bytes-ref bstr i)) (if (<= (char->integer #\0) b (char->integer #\7)) (+ (* v 8) (- b (char->integer #\0))) diff -Nru racket-7.2+ppa2/collects/json/main.rkt racket-7.3+ppa1/collects/json/main.rkt --- racket-7.2+ppa2/collects/json/main.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/json/main.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -164,91 +164,297 @@ (define-values [l c p] (port-next-location i)) (raise-read-error (format "~a: ~a" who (apply format fmt args)) (object-name i) l c p #f)) - (define (skip-whitespace) (regexp-match? #px#"^\\s*" i)) + (define (skip-whitespace) + (define ch (peek-char i)) + (cond + [(and (char? ch) (char-whitespace? ch)) + (read-char i) + (skip-whitespace)] + [else ch])) + (define (byte-char=? b ch) + (eqv? b (char->integer ch))) ;; ;; Reading a string *could* have been nearly trivial using the racket ;; reader, except that it won't handle a "\/"... - (define (read-string) - (define result (open-output-bytes)) - (let loop () - (define esc - (let loop () - (define c (read-byte i)) - (cond - [(eof-object? c) (err "unterminated string")] - [(= c 34) #f] ;; 34 = " - [(= c 92) (read-bytes 1 i)] ;; 92 = \ - [else (write-byte c result) (loop)]))) + (define (read-a-string) + ;; Using a string output port would make sense here, but managing + ;; a string buffer directly is even faster + (define result (make-string 16)) + (define (keep-char c old-result pos converter) + (define result + (cond + [(= pos (string-length old-result)) + (define new (make-string (* pos 2))) + (string-copy! new 0 old-result 0 pos) + new] + [else old-result])) + (string-set! result pos c) + (loop result (add1 pos) converter)) + (define (loop result pos converter) + (define c (read-byte i)) + (cond + [(eof-object? c) (err "unterminated string")] + [(byte-char=? c #\") (substring result 0 pos)] + [(byte-char=? c #\\) (read-escape (read-char i) result pos converter)] + [(c . < . 128) (keep-char (integer->char c) result pos converter)] + [else + ;; need to decode, but we can't un-read the byte, and + ;; also we want to report decoding errors + (define cvtr (or converter + (bytes-open-converter "UTF-8" "UTF-8"))) + (define buf (make-bytes 6 c)) + (let utf8-loop ([start 0] [end 1]) + (define-values (wrote-n read-n state) (bytes-convert cvtr buf start end buf 0 6)) + (case state + [(complete) + (keep-char (bytes-utf-8-ref buf 0) result pos cvtr)] + [(error) + (err "UTF-8 decoding error at ~e" (subbytes buf 0 end))] + [(aborts) + (define c (read-byte i)) + (cond + [(eof-object? c) + (err "unexpected end-of-file")] + [else + (bytes-set! buf end c) + (utf8-loop (+ start read-n) (add1 end))])]))])) + (define (read-escape esc result pos converter) (cond - [(not esc) (bytes->string/utf-8 (get-output-bytes result))] [(case esc - [(#"b") #"\b"] - [(#"n") #"\n"] - [(#"r") #"\r"] - [(#"f") #"\f"] - [(#"t") #"\t"] - [(#"\\") #"\\"] - [(#"\"") #"\""] - [(#"/") #"/"] + [(#\b) "\b"] + [(#\n) "\n"] + [(#\r) "\r"] + [(#\f) "\f"] + [(#\t) "\t"] + [(#\\) "\\"] + [(#\") "\""] + [(#\/) "/"] [else #f]) - => (λ (m) (write-bytes m result) (loop))] - [(equal? esc #"u") - (let* ([e (or (regexp-try-match #px#"^[a-fA-F0-9]{4}" i) - (err "bad string \\u escape"))] - [e (string->number (bytes->string/utf-8 (car e)) 16)]) - (define e* - (if (<= #xD800 e #xDFFF) - ;; it's the first part of a UTF-16 surrogate pair - (let* ([e2 (or (regexp-try-match #px#"^\\\\u([a-fA-F0-9]{4})" i) - (err "bad string \\u escape, ~a" - "missing second half of a UTF16 pair"))] - [e2 (string->number (bytes->string/utf-8 (cadr e2)) 16)]) - (if (<= #xDC00 e2 #xDFFF) - (+ (arithmetic-shift (- e #xD800) 10) (- e2 #xDC00) #x10000) - (err "bad string \\u escape, ~a" - "bad second half of a UTF16 pair"))) - e)) ; single \u escape - (write-string (string (integer->char e*)) result) - (loop))] - [else (err "bad string escape: \"~a\"" esc)]))) - ;; - (define (read-list what end-rx read-one) - (skip-whitespace) - (if (regexp-try-match end-rx i) - '() - (let loop ([l (list (read-one))]) - (skip-whitespace) - (cond [(regexp-try-match end-rx i) (reverse l)] - [(regexp-try-match #rx#"^," i) (loop (cons (read-one) l))] - [else (err "error while parsing a json ~a" what)])))) + => (λ (s) (keep-char (string-ref s 0) result pos converter))] + [(eqv? esc #\u) + (define (get-hex) + (define (read-next) + (define c (read-byte i)) + (when (eof-object? c) (error "unexpected end-of-file")) + c) + (define c1 (read-next)) + (define c2 (read-next)) + (define c3 (read-next)) + (define c4 (read-next)) + (define (hex-convert c) + (cond + [(<= (char->integer #\0) c (char->integer #\9)) + (- c (char->integer #\0))] + [(<= (char->integer #\a) c (char->integer #\f)) + (- c (- (char->integer #\a) 10))] + [(<= (char->integer #\A) c (char->integer #\F)) + (- c (- (char->integer #\A) 10))] + [else (err "bad \\u escape ~e" (bytes c1 c2 c3 c4))])) + (+ (arithmetic-shift (hex-convert c1) 12) + (arithmetic-shift (hex-convert c2) 8) + (arithmetic-shift (hex-convert c3) 4) + (hex-convert c4))) + (define e (get-hex)) + (define e* + (cond + [(<= #xD800 e #xDFFF) + (define (err-missing) + (err "bad string \\u escape, missing second half of a UTF-16 pair")) + (unless (eqv? (read-byte i) (char->integer #\\)) (err-missing)) + (unless (eqv? (read-byte i) (char->integer #\u)) (err-missing)) + (define e2 (get-hex)) + (cond + [(<= #xDC00 e2 #xDFFF) + (+ (arithmetic-shift (- e #xD800) 10) (- e2 #xDC00) #x10000)] + [else + (err "bad string \\u escape, bad second half of a UTF-16 pair")])] + [else e])) + (keep-char (integer->char e*) result pos converter)] + [else (err "bad string escape: \"~a\"" esc)])) + (loop result 0 #f)) + ;; + (define (read-list what end read-one) + (define ch (skip-whitespace)) + (cond + [(eqv? end ch) (read-byte i) + '()] + [else + (let loop ([l (list (read-one))]) + (define ch (skip-whitespace)) + (cond + [(eqv? ch end) (read-byte i) + (reverse l)] + [(eqv? ch #\,) (read-byte i) + (loop (cons (read-one) l))] + [else (err "error while parsing a json ~a" what)]))])) ;; (define (read-hash) (define (read-pair) (define k (read-json)) (unless (string? k) (err "non-string value used for json object key")) - (skip-whitespace) - (unless (regexp-try-match #rx#"^:" i) + (define ch (skip-whitespace)) + (unless (char=? #\: ch) (err "error while parsing a json object pair")) - (list (string->symbol k) (read-json))) - (apply hasheq (apply append (read-list 'object #rx#"^}" read-pair)))) + (read-byte i) + (cons (string->symbol k) (read-json))) + (for/hasheq ([p (in-list (read-list 'object #\} read-pair))]) + (values (car p) (cdr p)))) + ;; + (define (read-literal bstr) + (define len (bytes-length bstr)) + (read-byte i) + (for ([j (in-range 1 len)]) + (define c (read-byte i)) + (unless (eqv? c (bytes-ref bstr j)) + (bad-input (bytes-append (subbytes bstr 0 j) (bytes c))))) + ;; Check for delimiter, defined for our purposes as matching #rx"\\b": + (define b (peek-byte i)) + (unless (eof-object? b) + (when (or (<= (char->integer #\a) b (char->integer #\z)) + (<= (char->integer #\A) b (char->integer #\Z)) + (<= (char->integer #\0) b (char->integer #\9)) + (eqv? b (char->integer #\_))) + (bad-input bstr)))) + ;; + (define (read-number ch) + ;; match #rx#"^-?(?:0|[1-9][0-9]*)(?:\\.[0-9]+)?(?:[eE][+-]?[0-9]+)?" + (define (start) + (cond + [(eqv? ch #\-) + (read-byte i) + (read-integer -1)] + [else + (read-integer 1)])) + (define (digit-byte? c) + (and (not (eof-object? c)) + (<= (char->integer #\0) c (char->integer #\9)))) + (define (to-number c) + (- c (char->integer #\0))) + (define (maybe-bytes c) + (if (eof-object? c) #"" (bytes c))) + ;; used to reconstruct input for error reporting: + (define (n->string n exp) + (define s (number->string n)) + (string->bytes/utf-8 + (cond + [(zero? exp) s] + [else + (define m (+ (string-length s) exp)) + (string-append (substring s 0 m) "." (substring s m))]))) + ;; need at least one digit: + (define (read-integer sgn) + (define c (read-byte i)) + (cond + [(digit-byte? c) + (read-integer-rest sgn (to-number c) + #:more-digits? (not (eqv? c (char->integer #\0))))] + [else (bad-input (bytes-append (if (sgn . < . 0) #"-" #"") + (maybe-bytes c)) + #:eof? (eof-object? c))])) + ;; more digits: + (define (read-integer-rest sgn n #:more-digits? more-digits?) + (define c (peek-byte i)) + (cond + [(and more-digits? (digit-byte? c)) + (read-byte i) + (read-integer-rest sgn (+ (* n 10) (to-number c)) #:more-digits? #t)] + [(eqv? c (char->integer #\.)) + (read-byte i) + (read-fraction sgn n)] + [(or (eqv? c (char->integer #\e)) + (eqv? c (char->integer #\E))) + (read-byte i) + (read-exponent (* sgn n) c 0)] + [else (* sgn n)])) + ;; need at least one digit: + (define (read-fraction sgn n) + (define c (read-byte i)) + (cond + [(digit-byte? c) + (read-fraction-rest sgn (+ (* n 10) (to-number c)) -1)] + [else (bad-input (bytes-append (string->bytes/utf-8 (format "~a." (* sgn n))) + (maybe-bytes c)) + #:eof? (eof-object? c))])) + ;; more digits: + (define (read-fraction-rest sgn n exp) + (define c (peek-byte i)) + (cond + [(digit-byte? c) + (read-byte i) + (read-fraction-rest sgn (+ (* n 10) (to-number c)) (sub1 exp))] + [(or (eqv? c (char->integer #\e)) + (eqv? c (char->integer #\E))) + (read-byte i) + (read-exponent (* sgn n) c exp)] + [else (exact->inexact (* sgn n (expt 10 exp)))])) + ;; need at least one digit, maybe after +/-: + (define (read-exponent n mark exp) + (define c (read-byte i)) + (cond + [(digit-byte? c) + (read-exponent-rest n exp (to-number c))] + [(eqv? c (char->integer #\+)) + (read-exponent-more n mark #"+" exp 1)] + [(eqv? c (char->integer #\-)) + (read-exponent-more n mark #"-" exp -1)] + [else (bad-input (bytes-append (n->string n exp) + (bytes mark) + (maybe-bytes c)) + #:eof? (eof-object? c))])) + ;; need at least one digit, still: + (define (read-exponent-more n mark mark2 exp sgn) + (define c (read-byte i)) + (cond + [(digit-byte? c) + (read-exponent-rest n exp (* sgn (to-number c)))] + [else (bad-input (bytes-append (n->string n exp) + (bytes mark) + mark2 + (maybe-bytes c)) + #:eof? (eof-object? c))])) + ;; more digits: + (define (read-exponent-rest n exp exp2) + (define c (peek-byte i)) + (cond + [(digit-byte? c) + (read-byte i) + (read-exponent-rest n exp (+ (* 10 exp2) (to-number c)))] + [else (exact->inexact (* n (expt 10 (+ exp exp2))))])) + (start)) ;; (define (read-json [top? #f]) - (skip-whitespace) + (define ch (skip-whitespace)) (cond - [(and top? (eof-object? (peek-char i))) eof] - [(regexp-try-match #px#"^true\\b" i) #t] - [(regexp-try-match #px#"^false\\b" i) #f] - [(regexp-try-match #px#"^null\\b" i) jsnull] - [(regexp-try-match - #rx#"^-?(?:0|[1-9][0-9]*)(?:\\.[0-9]+)?(?:[eE][+-]?[0-9]+)?" i) - => (λ (bs) (string->number (bytes->string/utf-8 (car bs))))] - [(regexp-try-match #rx#"^[\"[{]" i) - => (λ (m) - (let ([m (car m)]) - (cond [(equal? m #"\"") (read-string)] - [(equal? m #"[") (read-list 'array #rx#"^\\]" read-json)] - [(equal? m #"{") (read-hash)])))] - [else (err (format "bad input~n ~e" (peek-bytes (sub1 (error-print-width)) 0 i)))])) + [(eof-object? ch) + (if top? + eof + (bad-input))] + [(eqv? ch #\t) (read-literal #"true") #t] + [(eqv? ch #\f) (read-literal #"false") #f] + [(eqv? ch #\n) (read-literal #"null") jsnull] + [(or (and ((char->integer ch) . <= . (char->integer #\9)) + ((char->integer ch) . >= . (char->integer #\0))) + (eqv? ch #\-)) + (read-number ch)] + [(eqv? ch #\") (read-byte i) + (read-a-string)] + [(eqv? ch #\[) (read-byte i) + (read-list 'array #\] read-json)] + [(eqv? ch #\{) (read-byte i) + (read-hash)] + [else (bad-input)])) + ;; + (define (bad-input [prefix #""] #:eof? [eof? #f]) + (define bstr (peek-bytes (sub1 (error-print-width)) 0 i)) + (if (or (and (eof-object? bstr) (equal? prefix #"")) + eof?) + (err (string-append "unexpected end-of-file" + (if (equal? prefix #"") + "" + (format "after ~e" prefix)))) + (err (format "bad input starting ~e" (bytes-append prefix (if (eof-object? bstr) + #"" + bstr)))))) ;; (read-json #t)) diff -Nru racket-7.2+ppa2/collects/net/git-checkout.rkt racket-7.3+ppa1/collects/net/git-checkout.rkt --- racket-7.2+ppa2/collects/net/git-checkout.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/net/git-checkout.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -51,7 +51,7 @@ #:strict-links? [strict-links? #f] #:username [username (current-git-username)] #:password [password (current-git-password)]) - (let retry-loop ([given-depth given-depth]) + (let retry-loop ([given-depth given-depth] [try-limit-depth (and given-depth 8)] [try-only-master? #t]) (define tmp-dir (or given-tmp-dir (make-temporary-file "git~a" 'directory))) (define port (or given-port (case transport @@ -91,7 +91,7 @@ ;; Find the commits needed for `ref`: (define-values (ref-commit ; #f or an ID string want-commits) ; list of ID string - (select-commits ref refs status)) + (select-commits ref refs status try-only-master?)) (unless dest-dir (write-pkt o) ; clean termination @@ -101,13 +101,16 @@ (or ref-commit ref))))) (define depth (and given-depth - ref-commit + (or ref-commit (and try-limit-depth + (eq? given-depth 1))) (cond - [(member "shallow" server-capabilities) - given-depth] - [else - (status "Server does not support `shallow`") - #f]))) + [(member "shallow" server-capabilities) + (if ref-commit + given-depth + try-limit-depth)] + [else + (status "Server does not support `shallow`") + #f]))) (unless dumb-protocol? ;; Tell the server which commits we need @@ -171,8 +174,7 @@ (lambda () (esc (lambda () (status "Unexpected EOF; retrying without depth") - (retry-loop #f))))))) - + (retry-loop #f #f #f))))))) (maybe-save-objects objs "objs") ;; Convert deltas into full objects withing `tmp`: @@ -182,8 +184,21 @@ (define commit (or ref-commit - (find-commit-as-reference ref obj-ids))) - + (find-commit-as-reference ref obj-ids + (and (or try-only-master? + (and try-limit-depth + (eqv? depth try-limit-depth))) + (lambda () + (esc (lambda () + (cond + [(and depth (eqv? depth try-limit-depth) + (try-limit-depth . < . 32)) + (status "no matching commit found; trying deeper search") + (retry-loop given-depth (* try-limit-depth 2) try-only-master?)] + [else + (status "no matching commit found; trying broader search") + (retry-loop given-depth #f #f)])))))))) + ;; Extract the tree from the packfile objects: (status "Extracting tree to ~a" dest-dir) (extract-commit-tree (hex-string->bytes commit) @@ -341,7 +356,7 @@ ;; initial response. If we can, the list of requested IDs will be ;; just that one. Otherwise, we'll have to return a list of all ;; IDs, and then we'll look for the reference later. -(define (select-commits ref refs status) +(define (select-commits ref refs status try-only-master?) (define ref-looks-like-id? (regexp-match? #rx"^[0-9a-f]+$" ref)) (define ref-rx (byte-regexp (bytes-append @@ -366,9 +381,16 @@ (cond [ref-commit (list ref-commit)] [ref-looks-like-id? - (status "Requested reference looks like commit id; getting all commits") - (for/list ([ref (in-list refs)]) - (cadr ref))] + (cond + [try-only-master? + (status "Requested reference looks like commit id; try within master") + (define-values (master-ref-commit want-commits) + (select-commits "master" refs status #f)) + want-commits] + [else + (status "Requested reference looks like commit id; getting all commits") + (for/list ([ref (in-list refs)]) + (cadr ref))])] [else (raise-git-error 'git "could not find requested reference\n reference: ~a" ref)])) @@ -601,7 +623,7 @@ ;; ---------------------------------------- ;; Finding a commit id -(define (find-commit-as-reference ref obj-ids) +(define (find-commit-as-reference ref obj-ids fail-not-found) (define rx (id-ref->regexp ref)) (define matches (for/list ([(id obj) (in-hash obj-ids)] @@ -611,7 +633,9 @@ (cond [(= 1 (length matches)) (car matches)] [(null? matches) - (raise-git-error 'git-checkout "no commit found matching id: ~a" ref)] + (if fail-not-found + (fail-not-found) + (raise-git-error 'git-checkout "no commit found matching id: ~a" ref))] [else (raise-git-error 'git-checkout "found multiple commits matching id: ~a" ref)])) diff -Nru racket-7.2+ppa2/collects/openssl/libcrypto.rkt racket-7.3+ppa1/collects/openssl/libcrypto.rkt --- racket-7.2+ppa2/collects/openssl/libcrypto.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/openssl/libcrypto.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -46,7 +46,10 @@ ;; Other specific known versions "1.0.1k" "1.0.1j" "1.0.1g" "1.0.1e" "1.0" "1.0.0" "1.0.0e" "1.0.0d" "1.0.0c" "1.0.0b" "1.0.0a" - "0.9.8e" "0.9.8b" "0.9.8" "0.9.7")) + "0.9.8e" "0.9.8b" "0.9.8" "0.9.7" + + ;; Known versions for *BSD variants + "111")) (define libcrypto-load-fail-reason #f) diff -Nru racket-7.2+ppa2/collects/pkg/main.rkt racket-7.3+ppa1/collects/pkg/main.rkt --- racket-7.2+ppa2/collects/pkg/main.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/pkg/main.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -14,7 +14,7 @@ (for-syntax racket/base syntax/strip-context)) -(define (setup what no-setup? fail-fast? setup-collects jobs) +(define (setup what no-setup? recompile-only? fail-fast? setup-collects jobs) (unless (or (eq? setup-collects 'skip) no-setup? (not (member (getenv "PLT_PKG_NOSETUP") '(#f "")))) @@ -29,6 +29,7 @@ #:tidy? #t #:make-doc-index? #t #:jobs jobs + #:recompile-only? recompile-only? #:fail-fast? fail-fast?) ((current-pkg-error) "packages ~a, although setup reported errors" @@ -253,7 +254,7 @@ (pkg-desc p a-type* name checksum #f #:path (and (eq? a-type* 'clone) (path->complete-path clone)))))))) - (setup "installed" no-setup fail-fast setup-collects jobs))))] + (setup "installed" no-setup recompile-only fail-fast setup-collects jobs))))] ;; ---------------------------------------- [update "Update packages" @@ -357,7 +358,7 @@ #:infer-clone-from-dir? (not (or link static-link copy)) #:dry-run? dry-run #:use-trash? (not no-trash))))) - (setup "updated" no-setup #f setup-collects jobs))))] + (setup "updated" no-setup recompile-only #f setup-collects jobs))))] ;; ---------------------------------------- [remove "Remove packages" @@ -385,7 +386,7 @@ #:force? force #:dry-run? dry-run #:use-trash? (not no-trash)))) - (setup "removed" no-setup #f setup-collects jobs)))] + (setup "removed" no-setup recompile-only #f setup-collects jobs)))] ;; ---------------------------------------- [new "Populate a new directory with the stubs of a package" @@ -484,7 +485,7 @@ (and binary-lib 'binary-lib)) #:force-strip? force #:dry-run? dry-run)))) - (setup "migrated" no-setup #f setup-collects jobs)))] + (setup "migrated" no-setup recompile-only #f setup-collects jobs)))] ;; ---------------------------------------- [create "Bundle package from a directory or installed package" @@ -674,7 +675,8 @@ #:dry-run-flags ([#:bool dry-run () ("Don't actually change package installation")]) #:job-flags - ([#:bool no-setup () ("Don't `raco setup' after changing packages (usually a bad idea)")] + ([#:bool no-setup () ("Don't `raco setup` after changing packages (usually a bad idea)")] + [#:bool recompile-only () ("Expect built packages, possibly machine-independent")] [(#:num n #f) jobs ("-j") "Setup with parallel jobs"] [#:bool batch () ("Disable interactive mode and all prompts")]) #:trash-flags diff -Nru racket-7.2+ppa2/collects/pkg/private/install.rkt racket-7.3+ppa1/collects/pkg/private/install.rkt --- racket-7.2+ppa2/collects/pkg/private/install.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/pkg/private/install.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -855,6 +855,7 @@ #:strict-doc-conflicts? [strict-doc-conflicts? #f] #:use-cache? [use-cache? #t] #:skip-installed? [skip-installed? #f] + #:skip-auto-installed? [skip-auto-installed? #f] #:pre-succeed [pre-succeed void] #:dep-behavior [dep-behavior #f] #:update-deps? [update-deps? #f] @@ -897,7 +898,7 @@ (filter (lambda (d) (define pkg-name (desc->name d)) (define i (hash-ref all-scope-dbs pkg-name #f)) - (or (not i) (pkg-info-auto? i))) + (or (not i) (and (not skip-auto-installed?) (pkg-info-auto? i)))) descs)) pkg-desc=?)) diff -Nru racket-7.2+ppa2/collects/pkg/private/migrate.rkt racket-7.3+ppa1/collects/pkg/private/migrate.rkt --- racket-7.2+ppa2/collects/pkg/private/migrate.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/pkg/private/migrate.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -79,6 +79,7 @@ #:strict-doc-conflicts? strict-doc-conflicts? #:use-cache? use-cache? #:skip-installed? #t + #:skip-auto-installed? #t #:dep-behavior (or dep-behavior 'search-auto) #:quiet? quiet? #:from-command-line? from-command-line? diff -Nru racket-7.2+ppa2/collects/pkg/private/new.rkt racket-7.3+ppa1/collects/pkg/private/new.rkt --- racket-7.2+ppa2/collects/pkg/private/new.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/pkg/private/new.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -117,6 +117,7 @@ - RACKET_VERSION=6.12 - RACKET_VERSION=7.0 - RACKET_VERSION=7.1 + - RACKET_VERSION=7.2 - RACKET_VERSION=HEAD matrix: diff -Nru racket-7.2+ppa2/collects/pkg/private/stage.rkt racket-7.3+ppa1/collects/pkg/private/stage.rkt --- racket-7.2+ppa2/collects/pkg/private/stage.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/pkg/private/stage.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -625,10 +625,16 @@ (define pkg-dir (if in-place? (if strip-mode - (pkg-error "cannot strip directory in place") + (cond + [in-place-clean? + (unless force-strip? + (check-strip-compatible strip-mode pkg-name pkg-path pkg-error)) + (generate-stripped-directory strip-mode pkg-path pkg-path) + pkg-path] + [else + (pkg-error "cannot strip directory in place\n path: ~a" pkg-path)]) pkg-path) (let ([pkg-dir (make-temporary-file "pkg~a" 'directory)]) - (delete-directory pkg-dir) (if strip-mode (begin (unless force-strip? @@ -637,6 +643,7 @@ (generate-stripped-directory strip-mode pkg-path pkg-dir)) (begin (make-parent-directory* pkg-dir) + (delete-directory pkg-dir) (copy-directory/files pkg-path pkg-dir #:keep-modify-seconds? #t))) pkg-dir))) (when (or (not in-place?) @@ -705,7 +712,7 @@ #:given-checksum (pkg-desc-checksum desc) #:use-cache? use-cache? #t - (if quiet? void printf) + (if quiet? void printf/flush) metadata-ns #:in-place? in-place? #:strip strip-mode diff -Nru racket-7.2+ppa2/collects/pkg/strip.rkt racket-7.3+ppa1/collects/pkg/strip.rkt --- racket-7.2+ppa2/collects/pkg/strip.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/pkg/strip.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -224,18 +224,20 @@ [(and keep? (file-exists? old-p)) (when drop-all-by-default? (make-directory* (path-only new-p))) - (copy-file old-p new-p) - (file-or-directory-modify-seconds - new-p - (file-or-directory-modify-seconds old-p)) + (unless (equal? old-p new-p) + (copy-file old-p new-p) + (file-or-directory-modify-seconds + new-p + (file-or-directory-modify-seconds old-p))) (fixup new-p path base level)] [(directory-exists? old-p) (define-values (new-drops new-keeps) (add-drop+keeps old-p p drops keeps)) - (when keep? - (if drop-all-by-default? - (make-directory* new-p) - (make-directory new-p))) + (unless (equal? old-p new-p) + (when keep? + (if drop-all-by-default? + (make-directory* new-p) + (make-directory new-p)))) (explore p (directory-list old-p) new-drops @@ -243,6 +245,7 @@ (not keep?) next-level)] [keep? (error 'strip "file or directory disappeared?")] + [(equal? old-p new-p) (delete-directory/files old-p)] [else (void)]))) (define-values (drops keeps) diff -Nru racket-7.2+ppa2/collects/racket/contract/base.rkt racket-7.3+ppa1/collects/racket/contract/base.rkt --- racket-7.2+ppa2/collects/racket/contract/base.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/contract/base.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -143,6 +143,7 @@ get/build-val-first-projection suggest/c + struct-guard/c ;; not documented.... (ie unintentional export) n->th) diff -Nru racket-7.2+ppa2/collects/racket/contract/private/and.rkt racket-7.3+ppa1/collects/racket/contract/private/and.rkt --- racket-7.2+ppa2/collects/racket/contract/private/and.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/contract/private/and.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -148,6 +148,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property + #:trusted trust-me #:late-neg-projection first-order-late-neg-and-proj #:name and-name #:first-order and-first-order @@ -158,6 +159,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract (build-chaperone-contract-property + #:trusted trust-me #:late-neg-projection late-neg-and-proj #:name and-name #:first-order and-first-order @@ -168,6 +170,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property + #:trusted trust-me #:late-neg-projection late-neg-and-proj #:name and-name #:first-order and-first-order @@ -356,6 +359,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property + #:trusted trust-me #:name integer-in-name #:first-order integer-in-first-order #:stronger integer-in-stronger @@ -365,6 +369,7 @@ (struct renamed-integer-in integer-in-ctc (name) #:property prop:flat-contract (build-flat-contract-property + #:trusted trust-me #:name (λ (ctc) (renamed-integer-in-name ctc)) #:first-order integer-in-first-order #:stronger integer-in-stronger diff -Nru racket-7.2+ppa2/collects/racket/contract/private/arr-d.rkt racket-7.3+ppa1/collects/racket/contract/private/arr-d.rkt --- racket-7.2+ppa2/collects/racket/contract/private/arr-d.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/contract/private/arr-d.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -577,6 +577,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property + #:trusted trust-me #:late-neg-projection (late-neg-->d-proj impersonate-procedure) #:name (->d-name #|print-as-method-if-method?|# #t) #:first-order ->d-first-order diff -Nru racket-7.2+ppa2/collects/racket/contract/private/arr-i-parse.rkt racket-7.3+ppa1/collects/racket/contract/private/arr-i-parse.rkt --- racket-7.2+ppa2/collects/racket/contract/private/arr-i-parse.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/contract/private/arr-i-parse.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -55,6 +55,8 @@ ;; 'desc => #:pre/desc or #:post/desc ;; 'bool => #:pre or #:post (struct pre/post (vars kind exp quoted-dep-src-code) #:transparent) +(struct pre/post-pre pre/post () #:transparent) +(struct pre/post-post pre/post () #:transparent) (define (parse-->i stx) (if (identifier? stx) @@ -487,12 +489,12 @@ [x (void)]) (for-each (λ (x) (check-id stx x)) (syntax->list #'(id ...))) (loop #'pre-leftover - (cons (pre/post (syntax->list #'(id ...)) - (if (equal? '#:pre/desc (syntax-e #'kwd)) - 'desc - 'bool) - #'pre-cond - (compute-quoted-src-expression #'pre-cond)) + (cons (pre/post-pre (syntax->list #'(id ...)) + (if (equal? '#:pre/desc (syntax-e #'kwd)) + 'desc + 'bool) + #'pre-cond + (compute-quoted-src-expression #'pre-cond)) conditions)))] [(kwd . rest) (or (equal? (syntax-e #'kwd) '#:pre) @@ -523,10 +525,10 @@ stx #'str)) (loop #'pre-leftover - (cons (pre/post (syntax->list #'(id ...)) - (syntax-e #'str) - #'pre-cond - (compute-quoted-src-expression #'pre-cond)) + (cons (pre/post-pre (syntax->list #'(id ...)) + (syntax-e #'str) + #'pre-cond + (compute-quoted-src-expression #'pre-cond)) conditions)))] [(#:pre/name . rest) (raise-syntax-error @@ -564,12 +566,12 @@ stx #'post-cond)] [_ (void)]) (loop #'leftover - (cons (pre/post (syntax->list #'(id ...)) - (if (equal? (syntax-e #'kwd) '#:post/desc) - 'desc - 'bool) - #'post-cond - (compute-quoted-src-expression #'post-cond)) + (cons (pre/post-post (syntax->list #'(id ...)) + (if (equal? (syntax-e #'kwd) '#:post/desc) + 'desc + 'bool) + #'post-cond + (compute-quoted-src-expression #'post-cond)) post-conds)))] [(kwd a b . stuff) (or (equal? (syntax-e #'kwd) '#:post/desc) @@ -589,7 +591,7 @@ (format "expected a sequence of variables and an expression to follow ~a" (syntax-e #'kwd)) stx #'a))] - [(#:post/name (id ...) str post-cond . pre-leftover) + [(#:post/name (id ...) str post-cond . post-leftover) (begin (for-each (λ (x) (check-id stx x)) (syntax->list #'(id ...))) (syntax-case range (any) @@ -604,9 +606,10 @@ " declaration to be a string") stx #'str)) - (loop #'pre-leftover - (cons (pre/post (syntax->list #'(id ...)) (syntax-e #'str) #'post-cond - (compute-quoted-src-expression #'post-cond)) + (loop #'post-leftover + (cons (pre/post-post (syntax->list #'(id ...)) (syntax-e #'str) + #'post-cond + (compute-quoted-src-expression #'post-cond)) post-conds)))] [(#:post/name . stuff) (begin @@ -661,4 +664,6 @@ (struct-out arg) (struct-out lres) (struct-out eres) - (struct-out pre/post)) + (struct-out pre/post) + (struct-out pre/post-pre) + (struct-out pre/post-post)) diff -Nru racket-7.2+ppa2/collects/racket/contract/private/arr-i.rkt racket-7.3+ppa1/collects/racket/contract/private/arr-i.rkt --- racket-7.2+ppa2/collects/racket/contract/private/arr-i.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/contract/private/arr-i.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -13,10 +13,10 @@ racket/stxparam-exptime syntax/name "arr-i-parse.rkt" - + (rename-in syntax/private/boundmap - ;; the private version of the library + ;; the private version of the library ;; (the one without contracts) ;; has these old, wrong names in it. [make-module-identifier-mapping make-free-identifier-mapping] @@ -33,18 +33,18 @@ (define indy-arg-ctc-projs (map (λ (x) (get/build-late-neg-projection (cdr x))) (->i-indy-arg-ctcs ctc))) (define rng-ctc-projs (map (λ (x) (get/build-late-neg-projection (cdr x))) (->i-rng-ctcs ctc))) - (define indy-rng-ctc-projs (map (λ (x) (get/build-late-neg-projection (cdr x))) + (define indy-rng-ctc-projs (map (λ (x) (get/build-late-neg-projection (cdr x))) (->i-indy-rng-ctcs ctc))) (define has-rest (->i-rest ctc)) (define here (->i-here ctc)) - + (define blames (for/list ([blame-info (->i-blame-info ctc)]) (define name (vector-ref blame-info 0)) (define indy? (vector-ref blame-info 1)) (define dom? (vector-ref blame-info 2)) (define non-indy-blame (blame-add-context - blame + blame (format (if dom? "the ~a argument of" "the ~a result of") name) #:swap? dom?)) @@ -54,39 +54,39 @@ (define swapped-blame (blame-swap blame)) (define indy-dom-blame (blame-replace-negative swapped-blame here)) (define indy-rng-blame (blame-replace-negative blame here)) - - (define partial-doms + + (define partial-doms (for/list ([dom-proj (in-list arg-ctc-projs)] [pr (in-list (->i-arg-ctcs ctc))]) - (dom-proj (blame-add-context swapped-blame + (dom-proj (blame-add-context swapped-blame (format "the ~a argument of" (->i-arg-name pr)))))) (define partial-indy-doms (for/list ([dom-proj (in-list indy-arg-ctc-projs)] [dom-pr (in-list (->i-indy-arg-ctcs ctc))]) - (dom-proj (blame-add-context indy-dom-blame + (dom-proj (blame-add-context indy-dom-blame (format "the ~a argument of" (car dom-pr)))))) - - (define partial-rngs + + (define partial-rngs (for/list ([rng-proj (in-list rng-ctc-projs)] [pr (in-list (->i-rng-ctcs ctc))] [n (in-naturals 1)]) (define name (car pr)) - (rng-proj (blame-add-context blame + (rng-proj (blame-add-context blame (if (eq? '_ name) (if (null? (cdr rng-ctc-projs)) "the result of" (format "the ~a result of" (n->th n))) (format "the ~a result of" name)))))) - (define partial-indy-rngs + (define partial-indy-rngs (for/list ([rng-proj (in-list indy-rng-ctc-projs)] [rng-pr (in-list (->i-indy-rng-ctcs ctc))]) - (rng-proj (blame-add-context indy-rng-blame (format "the ~a result of" + (rng-proj (blame-add-context indy-rng-blame (format "the ~a result of" (car rng-pr)))))) (list* c-or-i-procedure (λ (val mtd?) (if has-rest (check-procedure/more val mtd? - (->i-mandatory-args ctc) + (->i-mandatory-args ctc) (->i-mandatory-kwds ctc) (->i-opt-kwds ctc) blame #f) @@ -143,13 +143,13 @@ (values (λ (f) (call-with-values (λ () - (define kwd-args + (define kwd-args (for/list ([kwd-gen (in-list kwd-gens)]) (kwd-gen))) - (define regular-args + (define regular-args (for/list ([gen (in-list gens)]) (gen))) - (keyword-apply + (keyword-apply f dom-kwds kwd-args @@ -187,28 +187,18 @@ ;; rest : (or/c symbol? #f) ;; here : quoted-spec for use in assigning indy blame ;; mk-wrapper : creates the a wrapper function that implements the contract checking -(struct ->i (blame-info +(struct ->i (blame-info arg-ctcs arg-dep-ctcs indy-arg-ctcs rng-ctcs rng-dep-ctcs indy-rng-ctcs pre/post-procs mandatory-args opt-args mandatory-kwds opt-kwds rest - mtd? here mk-wrapper mk-val-first-wrapper name-info) + mtd? here mk-wrapper name-info) #:property prop:custom-write custom-write-property-proc) (define (mk-prop chaperone?) (define c-or-i-procedure (if chaperone? chaperone-procedure impersonate-procedure)) ((if chaperone? build-chaperone-contract-property build-contract-property) - #:val-first-projection - (λ (ctc) - (define blame-accepting-proj (arr->i-late-neg-proj ctc c-or-i-procedure)) - (maybe-warn-about-val-first ctc) - (λ (blame) - (define val+neg-party-accepting-proj (blame-accepting-proj blame)) - (λ (val) - (wrapped-extra-arg-arrow - (λ (neg-party) - (val+neg-party-accepting-proj val neg-party)) - (->i-mk-val-first-wrapper ctc))))) + #:trusted trust-me #:late-neg-projection (λ (ctc) (arr->i-late-neg-proj ctc c-or-i-procedure)) #:name (λ (ctc) @@ -335,23 +325,26 @@ rng-ctcs rng-dep-ctcs indy-rng-ctcs pre/post-procs mandatory-args opt-args mandatory-kwds opt-kwds rest - mtd? here mk-wrapper mk-val-first-wrapper name-info) + mtd? here mk-wrapper name-info) (define maker (if is-chaperone-contract? chaperone->i impersonator->i)) (maker blame-info arg-ctcs arg-dep-ctcs indy-arg-ctcs rng-ctcs rng-dep-ctcs indy-rng-ctcs pre/post-procs mandatory-args opt-args mandatory-kwds opt-kwds rest - mtd? here mk-wrapper mk-val-first-wrapper name-info)) + mtd? here mk-wrapper name-info)) -;; find-ordering : (listof arg) -> (values (listof arg) (listof number)) +;; find-ordering : (listof (or/c pre/post arg)) +;; -> (values (listof (or/c pre/pos arg) (listof (or/c #f nat))) ;; sorts the arguments according to the dependency order. ;; returns them in the reverse of that order, ie expressions that need ;; to be evaluted first come later in the list. +;; the second result maps back from the sorted order +;; (in the first result) to the original order (in `args`) (define-for-syntax (find-ordering args) - + #| This uses a variation of the topological sorting algorithm @@ -362,44 +355,76 @@ evaluted left-to-right.) |# - - (define numbers (make-hasheq)) ;; this uses eq?, but it could use a number in the 'arg' struct + + + ;; set up some unreferred to variables for + ;; the pre/post conditions to base the graph on + ;; get-var : (or/c pre/post arg) -> identifier + ;; (unfortuntately we rely on `eq?` here) + (define pre/post-fake-vars (make-hasheq)) + (for ([arg (in-list args)] + #:when (pre/post? arg)) + (hash-set! pre/post-fake-vars arg + (car (generate-temporaries (list arg))))) + (define (get-var arg) + (if (arg/res? arg) + (arg/res-var arg) + (hash-ref pre/post-fake-vars arg))) + + ;; track the indicies into `args` for the nodes in the graph + ;; and do the same thing but only for the subset that are actually args + ;; (unfortuntately we rely on `eq?` here) + (define numbers (make-hasheq)) (define id->arg/res (make-free-identifier-mapping)) (for ([arg (in-list args)] [i (in-naturals)]) (hash-set! numbers arg i) - (free-identifier-mapping-put! id->arg/res (arg/res-var arg) arg)) - + (free-identifier-mapping-put! id->arg/res (get-var arg) arg)) + + ;; track the original order of the pre/post conditions + (define pre/post-numbers (make-hasheq)) + (let ([i 0]) + (for ([arg (in-list args)]) + (when (pre/post? arg) + (hash-set! pre/post-numbers arg i) + (set! i (+ i 1))))) + ;; build the graph, where `comes-before` are the backwards + ;; edges and `comes-after` are the forwards edges + ;; we use new temporary variables for the pre/posts + ;; as they are not referred to (but only refer to other things) (define comes-before (make-free-identifier-mapping)) (define comes-after (make-free-identifier-mapping)) (for ([arg (in-list args)]) - (free-identifier-mapping-put! comes-before (arg/res-var arg) '()) - (free-identifier-mapping-put! comes-after (arg/res-var arg) '())) + (define the-var (get-var arg)) + (free-identifier-mapping-put! comes-before the-var '()) + (free-identifier-mapping-put! comes-after the-var '())) (for ([arg (in-list args)]) - (when (arg/res-vars arg) - (define arg-id (arg/res-var arg)) - (for ([dep-id (in-list (arg/res-vars arg))]) - (define dep (free-identifier-mapping-get id->arg/res dep-id (λ () #f))) - (when dep - ;; dep = #f should happen only when we're handling the result - ;; contracts and dep-id is one of the argument contracts. - ;; in that case, we can just ignore the edge since we know - ;; it will be bound already - (free-identifier-mapping-put! - comes-before - arg-id - (cons dep (free-identifier-mapping-get comes-before arg-id))) - (free-identifier-mapping-put! - comes-after - dep-id - (cons arg (free-identifier-mapping-get comes-after dep-id))))))) - + (define the-vars (if (arg/res? arg) + (or (arg/res-vars arg) '()) + (pre/post-vars arg))) + (define arg-id (get-var arg)) + (for ([dep-id (in-list the-vars)]) + (define dep (free-identifier-mapping-get id->arg/res dep-id (λ () #f))) + (when dep + ;; dep = #f should happen only when we're handling the result + ;; contracts and dep-id is one of the argument contracts. + ;; in that case, we can just ignore the edge since we know + ;; it will be bound already + (free-identifier-mapping-put! + comes-before + arg-id + (cons dep (free-identifier-mapping-get comes-before arg-id))) + (free-identifier-mapping-put! + comes-after + dep-id + (cons arg (free-identifier-mapping-get comes-after dep-id)))))) + (define sorted '()) (define no-incoming-edges (for/list ([arg (in-list args)] - #:when (null? (free-identifier-mapping-get comes-before (arg/res-var arg)))) + #:when (null? (free-identifier-mapping-get comes-before (get-var arg)))) arg)) - + (define (pick-next-node) (define least-node (let loop ([nodes (cdr no-incoming-edges)] @@ -415,100 +440,98 @@ (loop (cdr nodes) least-node)])]))) (set! no-incoming-edges (remove least-node no-incoming-edges)) least-node) - + (define (remove-edge from to) + (define from-id (get-var from)) + (define to-id (get-var to)) (free-identifier-mapping-put! comes-before - (arg/res-var to) - (remove from (free-identifier-mapping-get comes-before (arg/res-var to)))) + to-id + (remove from (free-identifier-mapping-get comes-before to-id))) (free-identifier-mapping-put! comes-after - (arg/res-var from) - (remove to (free-identifier-mapping-get comes-after (arg/res-var from))))) - + from-id + (remove to (free-identifier-mapping-get comes-after from-id)))) + (let loop () (unless (null? no-incoming-edges) (define n (pick-next-node)) (set! sorted (cons n sorted)) - (for ([m (in-list (free-identifier-mapping-get comes-after (arg/res-var n)))]) + (for ([m (in-list (free-identifier-mapping-get comes-after (get-var n)))]) (remove-edge n m) - (when (null? (free-identifier-mapping-get comes-before (arg/res-var m))) + (when (null? (free-identifier-mapping-get comes-before (get-var m))) (set! no-incoming-edges (cons m no-incoming-edges)))) (loop))) - + (values sorted (for/list ([arg (in-list sorted)]) - (hash-ref numbers arg)))) + (if (arg/res? arg) + (hash-ref numbers arg) + "pre/post, which has an index we don't want to use")) + pre/post-numbers)) ;; args/vars->arglist : (listof arg?) (vectorof identifier?) -> syntax ;; (vector-length vars) = (length args) ;; builds the parameter list for the wrapper λ -(define-for-syntax (args/vars->arglist an-istx vars this-param) - (let ([args (istx-args an-istx)]) - #`(#,@(if this-param - (list this-param) - '()) - . - #, - (let loop ([args args] - [i 0]) - (cond - [(null? args) (if (istx-rst an-istx) - #'rest-args - #'())] - [else - (let* ([arg (car args)] - [kwd (arg-kwd arg)] - [opt? (arg-optional? arg)] - [arg-exp - (cond - [(and kwd opt?) - #`(#,kwd [#,(vector-ref vars i) the-unsupplied-arg])] - [kwd - #`(#,kwd #,(vector-ref vars i))] - [opt? - #`([#,(vector-ref vars i) the-unsupplied-arg])] - [else - #`(#,(vector-ref vars i))])]) - - #`(#,@arg-exp - . - #,(loop (cdr args) (+ i 1))))]))))) +(define-for-syntax (args/vars->arglist an-istx wrapper-args this-param) + #`(#,@(if this-param + (list this-param) + '()) + . + #, + (let loop ([args (istx-args an-istx)]) + (cond + [(null? args) (if (istx-rst an-istx) + (hash-ref wrapper-args (istx-rst an-istx)) + #'())] + [else + (define arg (car args)) + (define kwd (arg-kwd arg)) + (define opt? (arg-optional? arg)) + (define wrapper-arg (hash-ref wrapper-args arg)) + (define arg-exp + (cond + [(and kwd opt?) + #`(#,kwd [#,wrapper-arg the-unsupplied-arg])] + [kwd + #`(#,kwd #,wrapper-arg)] + [opt? + #`([#,wrapper-arg the-unsupplied-arg])] + [else + #`(#,wrapper-arg)])) + #`(#,@arg-exp + . + #,(loop (cdr args)))])))) (define-for-syntax (all-but-last lst) (reverse (cdr (reverse lst)))) -;; vars : (listof identifier) -;; vars will contain one identifier for each arg, plus one more for rst, +;; wrapper-args : (listof identifier) +;; wrapper-args will contain one identifier for each arg, plus one more for rst, ;; unless rst is #f, in which case it just contains one identifier for each arg. ;; ;; FIXME: Currently, none of the resulting argument checkers attempt to preserve tail ;; recursion. If all of the result contracts (which would need to be passed to ;; this function as well as results-checkers) can be evaluated early, then we can ;; preserve tail recursion in the fashion of -> etc. -(define-for-syntax (args/vars->arg-checker result-checkers args rst vars this-param) +(define-for-syntax (args/vars->arg-checker result-checkers args rst wrapper-args this-param) (let ([opts? (ormap arg-optional? args)] [this-params (if this-param (list this-param) '())]) - (define arg->var (make-hash)) (define kwd-args (filter arg-kwd args)) (define non-kwd-args (filter (λ (x) (not (arg-kwd x))) args)) - - (for ([arg (in-list args)] - [var (in-vector vars)]) - (hash-set! arg->var arg var)) - - (define sorted-kwd/arg-pairs + + (define sorted-kwd/arg-pairs (sort - (map (λ (arg) (cons (arg-kwd arg) (hash-ref arg->var arg))) kwd-args) + (map (λ (arg) (cons (arg-kwd arg) (hash-ref wrapper-args arg))) kwd-args) (λ (x y) (keywordvar arg)) non-kwd-args)) + (define regular-arguments (map (λ (arg) (hash-ref wrapper-args arg)) non-kwd-args)) (cond [(and opts? (ormap arg-kwd args)) ;; has both optional and keyword args - #`(keyword-return/no-unsupplied - #,(if (null? result-checkers) #f (car result-checkers)) + #`(keyword-return/no-unsupplied + #,(if (null? result-checkers) #f (car result-checkers)) '#,(map car sorted-kwd/arg-pairs) (list #,@keyword-arguments) #,(if rst @@ -518,14 +541,15 @@ #,@regular-arguments)] [opts? ;; has optional args, but no keyword args + (define wrapper-args-as-list + (for/list ([arg (in-list args)]) + (hash-ref wrapper-args arg))) #`(return/no-unsupplied #,(if (null? result-checkers) #f (car result-checkers)) #,(if rst #'rest-args #''()) #,@this-params - #,@(if rst - (all-but-last (vector->list vars)) - (vector->list vars)))] + #,@wrapper-args-as-list)] [else (cond [(and (null? keyword-arguments) rst) @@ -533,15 +557,15 @@ [(null? keyword-arguments) #`(values #,@result-checkers #,@this-params #,@regular-arguments)] [rst - #`(apply values #,@result-checkers (list #,@keyword-arguments) + #`(apply values #,@result-checkers (list #,@keyword-arguments) #,@this-params #,@regular-arguments rest-args)] [else - #`(values #,@result-checkers (list #,@keyword-arguments) + #`(values #,@result-checkers (list #,@keyword-arguments) #,@this-params #,@regular-arguments)])]))) (define (return/no-unsupplied res-checker rest-args . args) (if res-checker - (apply values res-checker + (apply values res-checker (append (filter (λ (x) (not (eq? x the-unsupplied-arg))) args) rest-args)) (apply values (append (filter (λ (x) (not (eq? x the-unsupplied-arg))) args) rest-args)))) @@ -551,7 +575,7 @@ [kwd-args kwd-args]) (cond [(null? kwds) (values '() '())] - [else + [else (let-values ([(kwds-rec args-rec) (loop (cdr kwds) (cdr kwd-args))]) (cond [(eq? (car kwd-args) the-unsupplied-arg) @@ -566,10 +590,10 @@ [(null? supplied-kwd-args) (apply values (append (filter (λ (x) (not (eq? x the-unsupplied-arg))) args) rest-args))] [res-checker - (apply values res-checker supplied-kwd-args + (apply values res-checker supplied-kwd-args (append (filter (λ (x) (not (eq? x the-unsupplied-arg))) args) rest-args))] [else - (apply values supplied-kwd-args + (apply values supplied-kwd-args (append (filter (λ (x) (not (eq? x the-unsupplied-arg))) args) rest-args))]))) (define-for-syntax (maybe-generate-temporary x) @@ -580,7 +604,7 @@ (apply string-append (for/list ([var-info (in-list var-infos)]) - (format "\n ~s: ~e" + (format "\n ~s: ~e" (list-ref var-info 0) (list-ref var-info 1))))) (define msg @@ -589,7 +613,7 @@ [(or (equal? kind 'bool) (and (equal? kind 'desc) (equal? condition-result #f))) - (string-append + (string-append (if pre? "#:pre" "#:post") " condition violation" (if (null? var-infos) @@ -600,91 +624,87 @@ (pre-post/desc-result->string condition-result pre? '->i)])) (raise-blame-error blame #:missing-party neg-party val "~a" msg)) -(define-for-syntax (add-pre-cond an-istx indy-arg-vars ordered-args indy-res-vars ordered-ress - call-stx) - #`(begin #,@(for/list ([pre (in-list (istx-pre an-istx))] - [i (in-naturals)]) - (define id (string->symbol (format "pre-proc~a" i))) - #`(let ([condition-result - (#,id #,@(map (λ (var) (arg/res-to-indy-var indy-arg-vars - ordered-args - indy-res-vars - ordered-ress - var)) - (pre/post-vars pre)))]) - (unless #,(if (equal? (pre/post-kind pre) 'desc) - #'(equal? condition-result #t) - #'condition-result) - (signal-pre/post #t - val - '#,(pre/post-kind pre) - swapped-blame - neg-party - condition-result - #,@(map (λ (x) #`(list '#,x - #,(arg/res-to-indy-var indy-arg-vars - ordered-args - indy-res-vars - ordered-ress - x))) - (pre/post-vars pre)))))) +(define-for-syntax (add-pre-conds an-istx pre-indicies + indy-arg-vars ordered-args indy-res-vars ordered-ress + call-stx) + call-stx #; + #`(begin #,@(for/list ([pre (in-list (istx-pre an-istx))]) + (build-pre/post-code pre pre-indicies + indy-arg-vars ordered-args indy-res-vars ordered-ress)) #,call-stx)) -(define-for-syntax (add-post-cond an-istx indy-arg-vars ordered-args indy-res-vars ordered-ress - call-stx) - #`(begin #,@(for/list ([post (in-list (istx-post an-istx))] - [i (in-naturals)]) - (define id (string->symbol (format "post-proc~a" i))) - #`(let ([condition-result - (#,id #,@(map (λ (var) (arg/res-to-indy-var indy-arg-vars - ordered-args - indy-res-vars - ordered-ress - var)) - (pre/post-vars post)))]) - (unless #,(if (equal? (pre/post-kind post) 'desc) - #'(equal? condition-result #t) - #'condition-result) - (signal-pre/post - #f - val - '#,(pre/post-kind post) - blame - neg-party - condition-result - #,@(map (λ (x) #`(list '#,x #,(arg/res-to-indy-var indy-arg-vars - ordered-args - indy-res-vars - ordered-ress - x))) - (pre/post-vars post)))))) +(define-for-syntax (add-post-conds an-istx post-indices + indy-arg-vars ordered-args indy-res-vars ordered-ress + call-stx) + call-stx + #; + #`(begin #,@(for/list ([post (in-list (istx-post an-istx))]) + (build-pre/post-code post post-indices + indy-arg-vars ordered-args indy-res-vars ordered-ress)) #,call-stx)) +(define-for-syntax (build-pre/post-code a-pre/post pre-indicies/post-indicies + indy-arg-vars ordered-args indy-res-vars ordered-ress) + (define pre? (pre/post-pre? a-pre/post)) + (define id (string->symbol (format (if pre? "pre-proc~a" "post-proc~a") + (hash-ref pre-indicies/post-indicies a-pre/post)))) + #`(let ([condition-result + (#,id #,@(map (λ (var) (arg/res-to-indy-var indy-arg-vars + ordered-args + indy-res-vars + ordered-ress + var)) + (pre/post-vars a-pre/post)))]) + (unless #,(if (equal? (pre/post-kind a-pre/post) 'desc) + #'(equal? condition-result #t) + #'condition-result) + (signal-pre/post + #,pre? + val + '#,(pre/post-kind a-pre/post) + #,(if pre? #'swapped-blame #'blame) + neg-party + condition-result + #,@(map (λ (x) #`(list '#,x #,(arg/res-to-indy-var indy-arg-vars + ordered-args + indy-res-vars + ordered-ress + x))) + (pre/post-vars a-pre/post)))))) + ;; add-wrapper-let : ;; syntax? -- placed into the body position of the generated let expression ;; boolean? -- indicates if this is a chaperone contract ;; boolean? -- indicates if this is an arg or a res; affects only how blame-var-table is filled in -;; (listof arg/res) -- sorted version of the arg/res structs, ordered by evaluation order -;; (listof int) -- indices that give the mapping from the ordered-args to the original order -;; (listof identifier) -- arg/res-proj-vars, bound to projections with ordinary blame -;; (listof identifier) -- indy-arg/res-proj-args, bound to projections with indy blame -;; (listof identifier) -- wrapper-arg/ress, bound to the original, unwrapped values, sorted like -;; original arg/ress. the generated lets rebind these variables to their projected -;; counterparts, with normal blame -;; (listof identifier) -- indy-arg/res-vars, bound to wrapped values with indy blame, -;; sorted like the second input +;; (listof (or/c arg/res pre/post)) -- ordered-arg/reses, +;; sorted version of the arg/res and pre/post cond structs, +;; ordered by evaluation order +;; (listof (or/c int #f) -- indices that give the mapping from the ordered-args +;; to the original order, #f if this position is a pre/post-condition +;; (vectorof identifier) -- arg/res-proj-vars, bound to projections with ordinary blame +;; not in evaluation order, but in the order from istx +;; (vectorof identifier) -- indy-arg/res-proj-args, bound to projections with indy blame +;; not in evaluation order, but in the order from istx +;; (vectorof identifier) -- wrapper-arg/ress, bound to the original, unwrapped values, sorted like +;; original arg/ress (not evaluation order). the generated lets rebind these variables to +;; their projected counterparts, with normal blame +;; (listof identifier) -- indy-arg/res-vars, bound to wrapped values with indy blame, +;; sorted like `ordered-arg/reses` +;; (hash [pre/post -o> nat]) pre-indicies/post-indicies, indicates the original +;; ordering of the pre/post conditions (mapping from the order in indy-arg/res-vars +;; to the ordering in the original istx object, aka program order) ;; (listof identifier) (listof arg/var) (listof identifier) (listof arg/var) ;; the last four inputs are used only to call arg/res-to-indy-var. -;; boolean? -;; adds nested lets that bind the wrapper-args and the indy-arg/res-vars to projected values, +;; adds nested lets that bind the wrapper-args and the indy-arg/res-vars to projected values, ;; with 'body' in the body of the let also handles adding code to check to see if unsupplied -;; args are present (skipping the contract check, if so) -(define-for-syntax (add-wrapper-let body is-chaperone-contract? swapped-blame? neg-calls? +;; args are present (skipping the contract check, if so) +(define-for-syntax (add-wrapper-let body is-chaperone-contract? swapped-blame? ordered-arg/reses indicies - arg/res-proj-vars indy-arg/res-proj-vars + arg/res-proj-vars indy-arg/res-proj-vars wrapper-arg/ress indy-arg/res-vars + pre-indicies/post-indicies indy-arg-vars ordered-args indy-res-vars ordered-ress) - + (define (add-unsupplied-check an-arg/res wrapper-arg stx) (if (and (arg? an-arg/res) (arg-optional? an-arg/res)) @@ -692,103 +712,109 @@ #,wrapper-arg #,stx) stx)) - + (for/fold ([body body]) ([indy-arg/res-var (in-list indy-arg/res-vars)] [an-arg/res (in-list ordered-arg/reses)] - [index indicies] + [index (in-list indicies)] [i (in-naturals)]) - (let ([wrapper-arg (vector-ref wrapper-arg/ress index)] - [arg/res-proj-var (vector-ref arg/res-proj-vars index)] - [indy-arg/res-proj-var (vector-ref indy-arg/res-proj-vars index)]) - - ;; bound to the result of calling the dependent function - ;; (which isn't a contract directly, but is a function that returns - ;; the projection for a contract) - ;; the result computes what the contract will be for the given argument/res value. - (define contract-identifier (car (generate-temporaries (list indy-arg/res-var)))) - - (define indy-binding - ;; if indy-arg/res-proj-var is #f, that means that we don't need that binding, so skip it - (if indy-arg/res-proj-var - (list - #`[#,indy-arg/res-var - #,(add-unsupplied-check - an-arg/res - wrapper-arg - (if (arg/res-vars an-arg/res) - #`(#,(if is-chaperone-contract? #'un-dep/chaperone #'un-dep) - #,contract-identifier - #,wrapper-arg - #,(build-blame-identifier #t swapped-blame? (arg/res-var an-arg/res)) - neg-party - #t) - #`(#,indy-arg/res-proj-var #,wrapper-arg neg-party)))]) - (list))) - - #`(let (#,@(if (and (arg/res-vars an-arg/res) (not (eres? an-arg/res))) - (list #`[#,contract-identifier - #,(add-unsupplied-check - an-arg/res - wrapper-arg - #`(#,arg/res-proj-var - #,@(map (λ (var) - (arg/res-to-indy-var indy-arg-vars - ordered-args - indy-res-vars - ordered-ress - var)) - (arg/res-vars an-arg/res))))]) - (list))) - (let ([#,wrapper-arg + (cond + [(arg/res? an-arg/res) + (define wrapper-arg (hash-ref wrapper-arg/ress an-arg/res)) + (define arg/res-proj-var (vector-ref arg/res-proj-vars index)) + (define indy-arg/res-proj-var (vector-ref indy-arg/res-proj-vars index)) + + ;; bound to the result of calling the dependent function + ;; (which isn't a contract directly, but is a function that returns + ;; the projection for a contract) + ;; the result computes what the contract will be for the given argument/res value. + (define contract-identifier (car (generate-temporaries (list indy-arg/res-var)))) + + (define indy-binding + ;; if indy-arg/res-proj-var is #f, that means that we don't need that binding, so skip it + (if indy-arg/res-proj-var + (list + #`[#,indy-arg/res-var #,(add-unsupplied-check an-arg/res wrapper-arg - (cond - [(and (eres? an-arg/res) (arg/res-vars an-arg/res)) - #`(#,(if is-chaperone-contract? #'un-dep/chaperone #'un-dep) - #,(eres-eid an-arg/res) - #,wrapper-arg - #,(build-blame-identifier #f - swapped-blame? - (arg/res-var an-arg/res)) - neg-party - #f)] - [(arg/res-vars an-arg/res) - #`(#,(if is-chaperone-contract? #'un-dep/chaperone #'un-dep) - #,contract-identifier - #,wrapper-arg - #,(build-blame-identifier #f swapped-blame? (arg/res-var an-arg/res)) - neg-party - #f)] - [else - #`(#,arg/res-proj-var #,wrapper-arg neg-party)]))] - #,@indy-binding) - #,body))))) + (if (arg/res-vars an-arg/res) + #`(#,(if is-chaperone-contract? #'un-dep/chaperone #'un-dep) + #,contract-identifier + #,wrapper-arg + #,(build-blame-identifier #t swapped-blame? (arg/res-var an-arg/res)) + neg-party + #t) + #`(#,indy-arg/res-proj-var #,wrapper-arg neg-party)))]) + (list))) + + #`(let (#,@(if (and (arg/res-vars an-arg/res) (not (eres? an-arg/res))) + (list #`[#,contract-identifier + #,(add-unsupplied-check + an-arg/res + wrapper-arg + #`(#,arg/res-proj-var + #,@(map (λ (var) + (arg/res-to-indy-var indy-arg-vars + ordered-args + indy-res-vars + ordered-ress + var)) + (arg/res-vars an-arg/res))))]) + (list))) + (let ([#,wrapper-arg + #,(add-unsupplied-check + an-arg/res + wrapper-arg + (cond + [(and (eres? an-arg/res) (arg/res-vars an-arg/res)) + #`(#,(if is-chaperone-contract? #'un-dep/chaperone #'un-dep) + #,(eres-eid an-arg/res) + #,wrapper-arg + #,(build-blame-identifier #f + swapped-blame? + (arg/res-var an-arg/res)) + neg-party + #f)] + [(arg/res-vars an-arg/res) + #`(#,(if is-chaperone-contract? #'un-dep/chaperone #'un-dep) + #,contract-identifier + #,wrapper-arg + #,(build-blame-identifier #f swapped-blame? (arg/res-var an-arg/res)) + neg-party + #f)] + [else + #`(#,arg/res-proj-var #,wrapper-arg neg-party)]))] + #,@indy-binding) + #,body))] + [else + #`(begin #,(build-pre/post-code an-arg/res pre-indicies/post-indicies + indy-arg-vars ordered-args indy-res-vars ordered-ress) + #,body)]))) ;; (identifier arg -o> identifier) -- maps the original var in the arg to the corresponding indy-var ;; free-identifier-mapping[id -o> (listof (list/c boolean?[indy?] boolean?[dom?]))] -;; mutates blame-var-table to record which +;; mutates blame-var-table to record which ;; blame records needs to be computed (and passed in) (define-for-syntax (build-blame-ids ordered-args ordered-reses) (define blame-var-table (make-free-identifier-mapping)) (define needed-blame-vars (make-hash)) - + (define (add-blame-var indy? dom? id) (define olds (free-identifier-mapping-get blame-var-table id (λ () '()))) (define new (list indy? dom?)) (unless (member new olds) (free-identifier-mapping-put! blame-var-table id (cons new olds)))) - + (define (build-some ordered-arg/reses swapped-blame?) (for ([an-arg/res (in-list ordered-arg/reses)]) - (when (arg/res-vars an-arg/res) + (when (and (arg/res? an-arg/res) (arg/res-vars an-arg/res)) (add-blame-var #t swapped-blame? (arg/res-var an-arg/res)) (if (eres? an-arg/res) (add-blame-var #f swapped-blame? (arg/res-var an-arg/res)) (add-blame-var #f swapped-blame? (arg/res-var an-arg/res)))))) - + (build-some ordered-args #t) (build-some ordered-reses #f) @@ -815,36 +841,41 @@ ;; Returns an empty list if no result contracts and a list of a single syntax value ;; which should be a function from results to projection-applied versions of the same ;; if there are result contracts. -(define-for-syntax (build-result-checkers an-istx +(define-for-syntax (build-result-checkers an-istx post-indicies ordered-ress res-indices res-proj-vars indy-res-proj-vars wrapper-ress indy-res-vars ordered-args indy-arg-vars) (cond [(istx-ress an-istx) + (define wrapper-ress-as-list + (for/list ([a-res (in-list (istx-ress an-istx))]) + (hash-ref wrapper-ress a-res))) (list #`(case-lambda - [#,(vector->list wrapper-ress) + [#,wrapper-ress-as-list (with-contract-continuation-mark blame+neg-party - #,(add-wrapper-let - (add-post-cond an-istx indy-arg-vars ordered-args indy-res-vars ordered-ress - #`(values #,@(vector->list wrapper-ress))) + #,(add-wrapper-let + (add-post-conds an-istx post-indicies + indy-arg-vars ordered-args indy-res-vars ordered-ress + #`(values #,@wrapper-ress-as-list)) (istx-is-chaperone-contract? an-istx) - #f #f + #f ordered-ress res-indices - res-proj-vars indy-res-proj-vars + res-proj-vars indy-res-proj-vars wrapper-ress indy-res-vars + post-indicies indy-arg-vars ordered-args indy-res-vars ordered-ress))] [args (bad-number-of-results blame val - #,(vector-length wrapper-ress) + #,(length wrapper-ress-as-list) args)]))] [else null])) (define-for-syntax (add-eres-lets an-istx res-proj-vars - indy-arg-vars ordered-args indy-res-vars ordered-ress + indy-arg-vars ordered-args indy-res-vars ordered-ress stx) (cond [(and (positive? (vector-length res-proj-vars)) @@ -855,10 +886,10 @@ [res-proj-var (in-vector res-proj-vars (- (vector-length res-proj-vars) 1) -1 -1)]) (if (arg/res-vars an-arg/res) #`(let ([#,(eres-eid an-arg/res) - (#,res-proj-var #,@(map (λ (var) (arg/res-to-indy-var indy-arg-vars - ordered-args - indy-res-vars - ordered-ress + (#,res-proj-var #,@(map (λ (var) (arg/res-to-indy-var indy-arg-vars + ordered-args + indy-res-vars + ordered-ress var)) (arg/res-vars an-arg/res)))]) #,body) @@ -866,42 +897,57 @@ [else stx])) (define-for-syntax (mk-wrapper-func/blame-id-info stx an-istx used-indy-vars method?) - + (define-values (wrapper-proc-arglist blame-ids args+rst ordered-args arg-indices ordered-ress res-indices arg-proj-vars indy-arg-proj-vars - res-proj-vars indy-res-proj-vars) + res-proj-vars indy-res-proj-vars + pre-indicies post-indicies) (build-wrapper-proc-arglist an-istx used-indy-vars)) - - (define wrapper-args (list->vector - (append (generate-temporaries (map arg/res-var (istx-args an-istx))) - (if (istx-rst an-istx) - (list #'rest-args) - '())))) - (define indy-arg-vars (generate-temporaries (map arg/res-var ordered-args))) - - (define wrapper-ress - (list->vector (generate-temporaries (map arg/res-var (or (istx-ress an-istx) '()))))) + + ;; hash[arg/res -o> identifier] + (define wrapper-args (make-hasheq)) + (for ([an-arg/res (in-list (istx-args an-istx))]) + (hash-set! wrapper-args an-arg/res + (car (generate-temporaries (list (arg/res-var an-arg/res)))))) + (when (istx-rst an-istx) + (hash-set! wrapper-args (istx-rst an-istx) #'rest-args)) + + ;; hash[arg/res -o> identifier] + (define wrapper-ress (make-hasheq)) + (when (istx-ress an-istx) + (for ([an-arg/res (in-list (istx-ress an-istx))]) + (hash-set! wrapper-ress an-arg/res + (car (generate-temporaries (list (arg/res-var an-arg/res))))))) + + ;; indy-arg-vars & indy-res-vars + ;; contains `#f`s at the places where pre/post conditions go + (define indy-arg-vars + (for/list ([ordered-arg (in-list ordered-args)]) + (and (arg/res? ordered-arg) + (car (generate-temporaries (list (arg/res-var ordered-arg))))))) (define indy-res-vars - (generate-temporaries (map arg/res-var ordered-ress))) + (for/list ([ordered-arg (in-list ordered-ress)]) + (and (arg/res? ordered-arg) + (car (generate-temporaries (list (arg/res-var ordered-arg))))))) + - (define this-param (and method? (car (generate-temporaries '(this))))) - + (define wrapper-body - (add-wrapper-let - (add-pre-cond - an-istx + (add-wrapper-let + (add-pre-conds + an-istx pre-indicies indy-arg-vars ordered-args indy-res-vars ordered-ress (add-eres-lets an-istx res-proj-vars - indy-arg-vars ordered-args indy-res-vars ordered-ress + indy-arg-vars ordered-args indy-res-vars ordered-ress (args/vars->arg-checker (build-result-checkers - an-istx + an-istx post-indicies ordered-ress res-indices res-proj-vars indy-res-proj-vars wrapper-ress indy-res-vars @@ -911,10 +957,11 @@ wrapper-args this-param))) (istx-is-chaperone-contract? an-istx) - #t #f + #t ordered-args arg-indices - arg-proj-vars indy-arg-proj-vars + arg-proj-vars indy-arg-proj-vars wrapper-args indy-arg-vars + pre-indicies indy-arg-vars ordered-args indy-res-vars ordered-ress)) (values (map cdr blame-ids) @@ -947,61 +994,70 @@ (cond [(null? args) #f] [else - (let ([arg (arg/res-var (car args))] - [iarg (car iargs)]) - (cond - [(free-identifier=? var arg) iarg] - [else (loop (cdr iargs) (cdr args))]))]))) + (define arg (car args)) + (cond + [(arg/res? arg) + (define arg-var (arg/res-var (car args))) + (define iarg (car iargs)) + (cond + [(free-identifier=? var arg-var) iarg] + [else (loop (cdr iargs) (cdr args))])] + [else (loop (cdr iargs) (cdr args))])]))) (or (try indy-arg-vars ordered-args) (try indy-res-vars ordered-ress) (error '->i "internal error; did not find a matching var for ~s" var))) - + (define-for-syntax (build-wrapper-proc-arglist an-istx used-indy-vars) - - (define args+rst (append (istx-args an-istx) - (if (istx-rst an-istx) - (list (istx-rst an-istx)) - '()))) - (define-values (ordered-args arg-indices) (find-ordering args+rst)) - (define-values (ordered-ress res-indices) (if (istx-ress an-istx) - (find-ordering (istx-ress an-istx)) - (values '() '()))) - - - (define arg-proj-vars (list->vector (generate-temporaries (map arg/res-var args+rst)))) - + + (define pre+args+rst (append (istx-pre an-istx) + (istx-args an-istx) + (if (istx-rst an-istx) + (list (istx-rst an-istx)) + '()))) + (define res+post (append (istx-post an-istx) + (or (istx-ress an-istx) '()))) + (define-values (ordered-args arg-indices pre-indicies) (find-ordering pre+args+rst)) + (define-values (ordered-ress res-indices post-indicies) (find-ordering res+post)) + + (define arg-proj-vars + (for/vector ([pre+arg+rst (in-list pre+args+rst)]) + (and (arg/res? pre+arg+rst) + (car (generate-temporaries (list (arg/res-var pre+arg+rst))))))) + (define blame-ids (build-blame-ids ordered-args ordered-ress)) - - ;; this list is parallel to arg-proj-vars (so use arg-indices to find the right ones) + + ;; this vector is parallel to arg-proj-vars (so use arg-indices to find the right ones) ;; but it contains #fs in places where we don't need the indy projections (because the corresponding - ;; argument is not dependened on by anything) - (define indy-arg-proj-vars - (list->vector (map (λ (x) (maybe-generate-temporary - (and (free-identifier-mapping-get used-indy-vars - (arg/res-var x) - (λ () #f)) - (arg/res-var x)))) - args+rst))) - + ;; argument is not dependened on by anything or this one is a pre/post condition) + (define indy-arg-proj-vars + (for/vector ([an-arg/res (in-list pre+args+rst)]) + (and (arg/res? an-arg/res) + (maybe-generate-temporary + (and (free-identifier-mapping-get used-indy-vars + (arg/res-var an-arg/res) + (λ () #f)) + (arg/res-var an-arg/res)))))) + (define res-proj-vars - (list->vector (generate-temporaries (map arg/res-var (or (istx-ress an-istx) '()))))) - - + (for/vector ([an-arg/res (in-list res+post)]) + (and (arg/res? an-arg/res) + (car (generate-temporaries (list (arg/res-var an-arg/res))))))) + ;; this list is parallel to res-proj-vars (so use res-indices to find the right ones) - ;; but it contains #fs in places where we don't need the indy projections (because the + ;; but it contains #fs in places where we don't need the indy projections (because the ;; corresponding result is not dependened on by anything) - (define indy-res-proj-vars (list->vector (map (λ (x) - (maybe-generate-temporary - (and (free-identifier-mapping-get used-indy-vars - (arg/res-var x) - (λ () #f)) - (arg/res-var x)))) - (or (istx-ress an-istx) - '())))) - + (define indy-res-proj-vars + (for/vector ([an-arg/res (in-list res+post)]) + (and (arg/res? an-arg/res) + (maybe-generate-temporary + (and (free-identifier-mapping-get used-indy-vars + (arg/res-var an-arg/res) + (λ () #f)) + (arg/res-var an-arg/res)))))) + (define wrapper-proc-arglist #`(c-or-i-procedure chk ctc blame swapped-blame #,@(map car blame-ids) - + ;; the pre- and post-condition procs #,@(for/list ([pres (istx-pre an-istx)] [i (in-naturals)]) @@ -1009,85 +1065,58 @@ #,@(for/list ([pres (istx-post an-istx)] [i (in-naturals)]) (string->symbol (format "post-proc~a" i))) - + ;; first the non-dependent arg projections - #,@(filter values (map (λ (arg/res arg-proj-var) - (and (not (arg/res-vars arg/res)) arg-proj-var)) - args+rst - (vector->list arg-proj-vars))) + #,@(for/list ([arg/res (in-list pre+args+rst)] + [arg-proj-var (in-vector arg-proj-vars)] + #:when (and (arg/res? arg/res) + (not (arg/res-vars arg/res)))) + arg-proj-var) + ;; then the dependent arg projections - #,@(filter values (map (λ (arg/res arg-proj-var) - (and (arg/res-vars arg/res) arg-proj-var)) - args+rst - (vector->list arg-proj-vars))) + #,@(for/list ([arg/res (in-list pre+args+rst)] + [arg-proj-var (in-vector arg-proj-vars)] + #:when (and (arg/res? arg/res) + (arg/res-vars arg/res))) + arg-proj-var) + ;; then the non-dependent indy arg projections - #,@(filter values (map (λ (arg/res arg-proj-var) - (and (not (arg/res-vars arg/res)) arg-proj-var)) - args+rst - (vector->list indy-arg-proj-vars))) - + #,@(for/list ([arg/res (in-list pre+args+rst)] + [arg-proj-var (in-vector indy-arg-proj-vars)] + #:when (and (arg/res? arg/res) + (not (arg/res-vars arg/res)) + arg-proj-var)) + arg-proj-var) + ;; then the non-dependent res projections - #,@(filter values (map (λ (arg/res res-proj-var) - (and (not (arg/res-vars arg/res)) res-proj-var)) - (or (istx-ress an-istx) '()) - (vector->list res-proj-vars))) + #,@(for/list ([arg/res (in-list res+post)] + [res-proj-var (in-vector res-proj-vars)] + #:when (and (arg/res? arg/res) + (not (arg/res-vars arg/res)))) + res-proj-var) + ;; then the dependent res projections - #,@(filter values (map (λ (arg/res res-proj-var) - (and (arg/res-vars arg/res) res-proj-var)) - (or (istx-ress an-istx) '()) - (vector->list res-proj-vars))) + #,@(for/list ([arg/res (in-list res+post)] + [res-proj-var (in-vector res-proj-vars)] + #:when (and (arg/res? arg/res) + (arg/res-vars arg/res))) + res-proj-var) + ;; then the non-dependent indy res projections - #,@(filter values (map (λ (arg/res res-proj-var) - (and (not (arg/res-vars arg/res)) res-proj-var)) - (or (istx-ress an-istx) '()) - (vector->list indy-res-proj-vars))))) - + #,@(for/list ([arg/res (in-list res+post)] + [indy-res-proj-var (in-vector indy-res-proj-vars)] + #:when (and (arg/res? arg/res) + (not (arg/res-vars arg/res)) + indy-res-proj-var)) + indy-res-proj-var))) + (values wrapper-proc-arglist - blame-ids args+rst + blame-ids pre+args+rst ordered-args arg-indices ordered-ress res-indices arg-proj-vars indy-arg-proj-vars - res-proj-vars indy-res-proj-vars)) - -(define-for-syntax (mk-val-first-wrapper-func/blame-id-info an-istx used-indy-vars method?) - (define-values (wrapper-proc-arglist - blame-ids args+rst - ordered-args arg-indices - ordered-ress res-indices - arg-proj-vars indy-arg-proj-vars - res-proj-vars indy-res-proj-vars) - (build-wrapper-proc-arglist an-istx used-indy-vars)) - - (define wrapper-args (list->vector - (append (generate-temporaries (map arg/res-var (istx-args an-istx))) - (if (istx-rst an-istx) - (list #'rest-args) - '())))) - (define indy-arg-vars (generate-temporaries (map arg/res-var ordered-args))) - - (define wrapper-ress - (list->vector (generate-temporaries (map arg/res-var (or (istx-ress an-istx) '()))))) - (define indy-res-vars - (generate-temporaries (map arg/res-var ordered-ress))) - - - (define this-param (and method? (car (generate-temporaries '(this))))) - - #`(λ #,wrapper-proc-arglist - (λ (f) - (λ (neg-party #,@(args/vars->arglist an-istx wrapper-args this-param)) - #,(add-wrapper-let - (build-call-to-original-function - (istx-args an-istx) - (istx-rst an-istx) - wrapper-args - this-param) - (istx-is-chaperone-contract? an-istx) - #t #t - ordered-args arg-indices - arg-proj-vars indy-arg-proj-vars - wrapper-args indy-arg-vars - indy-arg-vars ordered-args indy-res-vars ordered-ress))))) + res-proj-vars indy-res-proj-vars + pre-indicies post-indicies)) (define-for-syntax (build-call-to-original-function args rst vars this-param) (define argument-list @@ -1100,7 +1129,7 @@ (list (arg-kwd arg) var)] [else (list var)])))) - (if rst + (if rst #`(apply f #,@argument-list rest-args) #`(f #,@argument-list))) @@ -1120,46 +1149,46 @@ (coerce-chaperone-contract '->i orig-ctc) (coerce-contract '->i orig-ctc))) (((get/build-late-neg-projection ctc) blame) obj neg-party)])) - + (define (un-dep/chaperone orig-ctc obj blame neg-party indy-blame?) (un-dep/maybe-chaperone orig-ctc obj blame neg-party #t indy-blame?)) - + (define (un-dep orig-ctc obj blame neg-party indy-blame?) (un-dep/maybe-chaperone orig-ctc obj blame neg-party #f indy-blame?))) (define-for-syntax (mk-used-indy-vars an-istx) (let ([vars (make-free-identifier-mapping)]) - + ;; add in regular arguments' uses (for ([an-arg (in-list (istx-args an-istx))]) (when (arg/res-vars an-arg) (for ([var (in-list (arg/res-vars an-arg))]) (free-identifier-mapping-put! vars var #t)))) - + ;; add in rest argument uses (when (istx-rst an-istx) (let ([an-arg/rst (istx-rst an-istx)]) (when (arg/res-vars an-arg/rst) (for ([var (in-list (arg/res-vars an-arg/rst))]) (free-identifier-mapping-put! vars var #t))))) - + ;; pre-condition (for ([pre (in-list (istx-pre an-istx))]) (for ([var (in-list (pre/post-vars pre))]) (free-identifier-mapping-put! vars var #t))) - + ;; results (when (istx-ress an-istx) (for ([a-res (in-list (istx-ress an-istx))]) (when (arg/res-vars a-res) (for ([var (in-list (arg/res-vars a-res))]) (free-identifier-mapping-put! vars var #t))))) - + ;; post-condition (for ([post (in-list (istx-post an-istx))]) (for ([var (in-list (pre/post-vars post))]) (free-identifier-mapping-put! vars var #t))) - + vars)) (define-syntax (->i/m stx) @@ -1172,8 +1201,6 @@ (define used-indy-vars (mk-used-indy-vars an-istx)) (define-values (blame-ids wrapper-func) (mk-wrapper-func/blame-id-info stx an-istx used-indy-vars method?)) - (define val-first-wrapper-func - (mk-val-first-wrapper-func/blame-id-info an-istx used-indy-vars method?)) (define args+rst (append (istx-args an-istx) (if (istx-rst an-istx) (list (istx-rst an-istx)) @@ -1182,13 +1209,13 @@ (append (or (istx-ress an-istx) '()) args+rst)) (define this->i (gensym 'this->i)) - (with-syntax ([(arg-exp-xs ...) - (generate-temporaries + (with-syntax ([(arg-exp-xs ...) + (generate-temporaries (filter values (map (λ (arg) (and (not (arg/res-vars arg)) (arg/res-var arg))) args+rst)))] [((arg-names arg-kwds arg-is-optional?s arg-exps) ...) - (filter values (map (λ (arg) (and (not (arg/res-vars arg)) + (filter values (map (λ (arg) (and (not (arg/res-vars arg)) (list (arg/res-var arg) (and (arg? arg) (arg-kwd arg)) @@ -1198,11 +1225,11 @@ (arg/res-ctc arg) 'racket/contract:negative-position this->i) - 'racket/contract:contract-on-boundary + 'racket/contract:contract-on-boundary (gensym '->i-indy-boundary))))) args+rst))] - - [(res-exp-xs ...) + + [(res-exp-xs ...) (if (istx-ress an-istx) (generate-temporaries (filter values (map (λ (res) (and (not (arg/res-vars res)) (arg/res-var res))) @@ -1210,19 +1237,19 @@ '())] [((res-names res-exps) ...) (if (istx-ress an-istx) - (filter values (map (λ (res) (and (not (arg/res-vars res)) + (filter values (map (λ (res) (and (not (arg/res-vars res)) (list (arg/res-var res) (syntax-property - (syntax-property + (syntax-property (arg/res-ctc res) 'racket/contract:positive-position this->i) - 'racket/contract:contract-on-boundary + 'racket/contract:contract-on-boundary (gensym '->i-indy-boundary))))) (istx-ress an-istx))) '())]) - + (define (find-orig-vars ids arg/ress-to-look-in) (for/list ([an-id (in-list ids)]) (define ans @@ -1230,13 +1257,13 @@ (and (free-identifier=? an-id (arg/res-var o-arg)) (arg/res-var o-arg)))) (unless ans - (error 'contract/arr-i.rkt:find-orig-vars + (error 'contract/arr-i.rkt:find-orig-vars "could not find ~s in ~s\n" an-id arg/ress-to-look-in)) ans)) (define is-chaperone-contract? (istx-is-chaperone-contract? an-istx)) - + #`(let ([arg-exp-xs (coerce-contract '->i arg-exps)] ... [res-exp-xs (coerce-contract '->i res-exps)] ...) #,(syntax-property @@ -1252,9 +1279,9 @@ (define orig-vars (find-orig-vars (arg/res-vars arg) args+rst)) (define ctc-stx (syntax-property - (syntax-property + (syntax-property (arg/res-ctc arg) - 'racket/contract:negative-position + 'racket/contract:negative-position this->i) 'racket/contract:contract-on-boundary (gensym '->i-indy-boundary))) @@ -1265,31 +1292,30 @@ #,ctc-stx))) ;; then the non-dependent argument contracts that are themselves depended on (list #,@(filter values - (map (λ (arg/res indy-id) + (map (λ (arg/res indy-id) (and (free-identifier-mapping-get used-indy-vars (arg/res-var arg/res) (λ () #f)) #`(cons '#,(arg/res-var arg/res) #,indy-id))) (filter (λ (arg/res) (not (arg/res-vars arg/res))) args+rst) (syntax->list #'(arg-exp-xs ...))))) - - + #,(if (istx-ress an-istx) #`(list (cons 'res-names res-exp-xs) ...) #''()) #,(if (istx-ress an-istx) - #`(list #,@(for/list ([arg (in-list + #`(list #,@(for/list ([arg (in-list (istx-ress an-istx))] #:when (arg/res-vars arg)) - (define orig-vars + (define orig-vars (find-orig-vars (arg/res-vars arg) args+rst+results)) (define arg-stx (syntax-property - (syntax-property + (syntax-property (arg/res-ctc arg) 'racket/contract:positive-position this->i) - 'racket/contract:contract-on-boundary + 'racket/contract:contract-on-boundary (gensym '->i-indy-boundary))) (if (eres? arg) #`(λ #,orig-vars @@ -1303,17 +1329,17 @@ #''()) #,(if (istx-ress an-istx) #`(list #,@(filter values - (map (λ (arg/res indy-id) - (and (free-identifier-mapping-get used-indy-vars + (map (λ (arg/res indy-id) + (and (free-identifier-mapping-get used-indy-vars (arg/res-var arg/res) (λ () #f)) #`(cons '#,(arg/res-var arg/res) #,indy-id))) - (filter (λ (arg/res) + (filter (λ (arg/res) (not (arg/res-vars arg/res))) (istx-ress an-istx)) (syntax->list #'(res-exp-xs ...))))) #''()) - + #,(let ([func (λ (pre/post vars-to-look-in) (define orig-vars (find-orig-vars (pre/post-vars pre/post) vars-to-look-in)) @@ -1324,30 +1350,29 @@ (func pre args+rst)) #,@(for/list ([post (in-list (istx-post an-istx))]) (func post args+rst+results)))) - - #,(length (filter values (map (λ (arg) (and (not (arg-kwd arg)) + + #,(length (filter values (map (λ (arg) (and (not (arg-kwd arg)) (not (arg-optional? arg)))) (istx-args an-istx)))) #,(length (filter values (map (λ (arg) (and (not (arg-kwd arg)) (arg-optional? arg))) (istx-args an-istx)))) - '#,(sort (filter values (map (λ (arg) (and (not (arg-optional? arg)) - (arg-kwd arg) + '#,(sort (filter values (map (λ (arg) (and (not (arg-optional? arg)) + (arg-kwd arg) (syntax-e (arg-kwd arg)))) - (istx-args an-istx))) + (istx-args an-istx))) keywordlist stx))]) @@ -1391,7 +1416,7 @@ (define pre (find-kwd '#:pre)) (define post (find-kwd '#:post)) (define orig (list (car (syntax-e stx)))) - (vector this->i + (vector this->i ;; the ->i in the original input to this guy (if post (cons post orig) orig) (if pre (list pre) '()))))))) diff -Nru racket-7.2+ppa2/collects/racket/contract/private/arrow-val-first.rkt racket-7.3+ppa1/collects/racket/contract/private/arrow-val-first.rkt --- racket-7.2+ppa2/collects/racket/contract/private/arrow-val-first.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/contract/private/arrow-val-first.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1560,6 +1560,7 @@ (base->-method? ->stct) #t))) (build-X-property + #:trusted trust-me #:name (base->-name #|print-as-method-if-method|# #t) #:first-order ->-first-order #:projection diff -Nru racket-7.2+ppa2/collects/racket/contract/private/base.rkt racket-7.3+ppa1/collects/racket/contract/private/base.rkt --- racket-7.2+ppa2/collects/racket/contract/private/base.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/contract/private/base.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1,6 +1,7 @@ #lang racket/base (provide contract + make-apply-contract (rename-out [-recursive-contract recursive-contract]) current-contract-region invariant-assertion @@ -68,6 +69,9 @@ #f)))])) (define (apply-contract c v pos neg name loc context-limit) + ((make-apply-contract c pos neg name loc context-limit) v)) + +(define (make-apply-contract c pos neg name loc context-limit [backwards? #f]) (let ([c (coerce-contract 'contract c)]) (check-source-location! 'contract loc) (define clnp (contract-late-neg-projection c)) @@ -87,13 +91,16 @@ (if clnp #f neg) #t #:context-limit context-limit)) + (define ccm-value (if clnp (cons blame neg) blame)) + (define-syntax-rule (with-ccm e) + (with-contract-continuation-mark ccm-value e)) (cond - [clnp (with-contract-continuation-mark - (cons blame neg) - ((clnp blame) v neg))] - [else (with-contract-continuation-mark - blame - (((contract-projection c) blame) v))]))) + [clnp + (define proj (with-ccm (clnp blame))) + (lambda (v) (with-ccm (proj v neg)))] + [else + (define proj (with-ccm ((contract-projection c) blame))) + (lambda (v) (with-ccm (proj v)))]))) (define-syntax (invariant-assertion stx) (syntax-case stx () @@ -317,6 +324,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property + #:trusted trust-me #:name recursive-contract-name #:first-order recursive-contract-first-order #:late-neg-projection flat-recursive-contract-late-neg-projection @@ -328,6 +336,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract (build-chaperone-contract-property + #:trusted trust-me #:name recursive-contract-name #:first-order recursive-contract-first-order #:late-neg-projection recursive-contract-late-neg-projection @@ -339,6 +348,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property + #:trusted trust-me #:name recursive-contract-name #:first-order recursive-contract-first-order #:late-neg-projection recursive-contract-late-neg-projection diff -Nru racket-7.2+ppa2/collects/racket/contract/private/blame.rkt racket-7.3+ppa1/collects/racket/contract/private/blame.rkt --- racket-7.2+ppa2/collects/racket/contract/private/blame.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/contract/private/blame.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -446,6 +446,10 @@ (define (blame/important-original? blme) (define i (blame-important blme)) (cond + [(equal? (blame-positive blme) (blame-negative blme)) + ;; if the positive and negative parties are the same, + ;; we never want to say "broke its own contract" + #f] [i (equal? (important-sense-swapped? i) (blame-original? blme))] [else (blame-original? blme)])) diff -Nru racket-7.2+ppa2/collects/racket/contract/private/box.rkt racket-7.3+ppa1/collects/racket/contract/private/box.rkt --- racket-7.2+ppa2/collects/racket/contract/private/box.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/contract/private/box.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -135,6 +135,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property + #:trusted trust-me #:name box/c-name #:first-order box/c-first-order #:stronger box/c-stronger @@ -206,6 +207,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract (build-chaperone-contract-property + #:trusted trust-me #:name box/c-name #:first-order box/c-first-order #:stronger box/c-stronger @@ -216,6 +218,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property + #:trusted trust-me #:name box/c-name #:first-order box/c-first-order #:stronger box/c-stronger diff -Nru racket-7.2+ppa2/collects/racket/contract/private/case-arrow.rkt racket-7.3+ppa1/collects/racket/contract/private/case-arrow.rkt --- racket-7.2+ppa2/collects/racket/contract/private/case-arrow.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/contract/private/case-arrow.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -289,6 +289,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract (build-chaperone-contract-property + #:trusted trust-me #:late-neg-projection (case->-proj chaperone-procedure) #:name (case->-name #|print-as-method-if-method?|# #t) #:first-order case->-first-order @@ -298,6 +299,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property + #:trusted trust-me #:late-neg-projection (case->-proj impersonate-procedure) #:name (case->-name #|print-as-method-if-method?|# #t) #:first-order case->-first-order diff -Nru racket-7.2+ppa2/collects/racket/contract/private/collapsible-common.rkt racket-7.3+ppa1/collects/racket/contract/private/collapsible-common.rkt --- racket-7.2+ppa2/collects/racket/contract/private/collapsible-common.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/contract/private/collapsible-common.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -143,7 +143,7 @@ (for/or ([old-ctc (in-list contract-list)]) (and old-ctc (flat-contract-struct? new-ctc) - (contract-struct-stronger? old-ctc new-ctc))))) + (trusted-contract-struct-stronger? old-ctc new-ctc))))) ;; join two collapsible-leaf contracts (define (join-collapsible-leaf/c new-collapsible new-neg old-collapsible old-neg) diff -Nru racket-7.2+ppa2/collects/racket/contract/private/ds.rkt racket-7.3+ppa1/collects/racket/contract/private/ds.rkt --- racket-7.2+ppa2/collects/racket/contract/private/ds.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/contract/private/ds.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -320,6 +320,7 @@ (define lazy-contract-property (build-contract-property + #:trusted trust-me #:projection lazy-contract-proj #:name lazy-contract-name #:first-order (lambda (ctc) predicate) diff -Nru racket-7.2+ppa2/collects/racket/contract/private/exists.rkt racket-7.3+ppa1/collects/racket/contract/private/exists.rkt --- racket-7.2+ppa2/collects/racket/contract/private/exists.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/contract/private/exists.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -32,6 +32,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property + #:trusted trust-me #:name (λ (ctc) (∀∃/c-name ctc)) #:first-order (λ (ctc) (λ (x) #t)) ;; ??? #:late-neg-projection ∀∃-late-neg-proj diff -Nru racket-7.2+ppa2/collects/racket/contract/private/guts.rkt racket-7.3+ppa1/collects/racket/contract/private/guts.rkt --- racket-7.2+ppa2/collects/racket/contract/private/guts.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/contract/private/guts.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -577,6 +577,7 @@ #:property prop:custom-write contract-custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property + #:trusted trust-me #:first-order (λ (ctc) (λ (x) (eq? (eq-contract-val ctc) x))) #:name (λ (ctc) (eq-contract-name ctc)) #:generate @@ -605,6 +606,7 @@ #:property prop:custom-write contract-custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property + #:trusted trust-me #:first-order (λ (ctc) (λ (x) (equal? (equal-contract-val ctc) x))) #:name (λ (ctc) (equal-contract-name ctc)) #:stronger @@ -629,6 +631,7 @@ #:property prop:custom-write contract-custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property + #:trusted trust-me #:first-order (λ (ctc) (λ (x) (and (number? x) (= (=-contract-val ctc) x)))) #:name (λ (ctc) (=-contract-name ctc)) #:stronger @@ -686,6 +689,7 @@ #:property prop:custom-write contract-custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property + #:trusted trust-me #:first-order (λ (ctc) (define low (char-in/c-low ctc)) @@ -738,6 +742,7 @@ #:property prop:custom-write contract-custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property + #:trusted trust-me #:first-order (λ (ctc) (define reg (regexp/c-reg ctc)) @@ -759,6 +764,7 @@ #:property prop:custom-write contract-custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property + #:trusted trust-me #:stronger predicate-contract-equivalent #:equivalent predicate-contract-equivalent #:name (λ (ctc) (predicate-contract-name ctc)) diff -Nru racket-7.2+ppa2/collects/racket/contract/private/hash.rkt racket-7.3+ppa1/collects/racket/contract/private/hash.rkt --- racket-7.2+ppa2/collects/racket/contract/private/hash.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/contract/private/hash.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -241,6 +241,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property + #:trusted trust-me #:name hash/c-name #:first-order hash/c-first-order #:generate hash/c-generate @@ -359,6 +360,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract (build-chaperone-contract-property + #:trusted trust-me #:name hash/c-name #:first-order hash/c-first-order #:generate hash/c-generate @@ -372,6 +374,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property + #:trusted trust-me #:name hash/c-name #:first-order hash/c-first-order #:stronger hash/c-stronger @@ -437,6 +440,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property + #:trusted trust-me #:name hash/dc-name #:first-order hash/dc-first-order #:equivalent hash/dc-equivalent @@ -446,6 +450,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract (build-chaperone-contract-property + #:trusted trust-me #:name hash/dc-name #:first-order hash/dc-first-order #:stronger hash/dc-stronger @@ -455,6 +460,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property + #:trusted trust-me #:name hash/dc-name #:first-order hash/dc-first-order #:stronger hash/dc-stronger diff -Nru racket-7.2+ppa2/collects/racket/contract/private/list.rkt racket-7.3+ppa1/collects/racket/contract/private/list.rkt --- racket-7.2+ppa2/collects/racket/contract/private/list.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/contract/private/list.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -235,6 +235,7 @@ (define flat-prop (build-flat-contract-property + #:trusted trust-me #:name list-name #:first-order list-fo-check #:late-neg-projection listof-late-neg-projection @@ -245,6 +246,7 @@ #:list-contract? (λ (c) (not (im-listof-ctc? c))))) (define chap-prop (build-chaperone-contract-property + #:trusted trust-me #:name list-name #:first-order list-fo-check #:late-neg-projection listof-late-neg-projection @@ -255,6 +257,7 @@ #:list-contract? (λ (c) (not (im-listof-ctc? c))))) (define full-prop (build-contract-property + #:trusted trust-me #:name list-name #:first-order list-fo-check #:late-neg-projection listof-late-neg-projection @@ -440,6 +443,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property + #:trusted trust-me #:late-neg-projection (cons/c-late-neg-ho-check (λ (v a d) v)) #:name cons/c-name #:first-order cons/c-first-order @@ -451,6 +455,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract (build-chaperone-contract-property + #:trusted trust-me #:late-neg-projection (cons/c-late-neg-ho-check (λ (v a d) (cons a d))) #:name cons/c-name #:first-order cons/c-first-order @@ -462,6 +467,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property + #:trusted trust-me #:late-neg-projection (cons/c-late-neg-ho-check (λ (v a d) (cons a d))) #:name cons/c-name #:first-order cons/c-first-order @@ -565,6 +571,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property + #:trusted trust-me #:late-neg-projection cons/dc-late-neg-projection #:name cons/dc-name #:first-order cons/dc-first-order @@ -576,6 +583,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract (build-chaperone-contract-property + #:trusted trust-me #:late-neg-projection cons/dc-late-neg-projection #:name cons/dc-name #:first-order cons/dc-first-order @@ -587,6 +595,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property + #:trusted trust-me #:late-neg-projection cons/dc-late-neg-projection #:name cons/dc-name #:first-order cons/dc-first-order @@ -728,6 +737,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property + #:trusted trust-me #:name list/c-name-proc #:first-order list/c-first-order #:generate list/c-generate @@ -817,6 +827,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract (build-chaperone-contract-property + #:trusted trust-me #:name list/c-name-proc #:first-order list/c-first-order #:generate list/c-generate @@ -830,6 +841,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property + #:trusted trust-me #:name list/c-name-proc #:first-order list/c-first-order #:generate list/c-generate @@ -1015,6 +1027,7 @@ (struct flat-*list/c *list-ctc () #:property prop:contract (build-contract-property + #:trusted trust-me #:name *list/c-name-proc #:first-order *list/c-first-order #:generate *list/c-generate @@ -1026,6 +1039,7 @@ (struct chaperone-*list/c *list-ctc () #:property prop:contract (build-contract-property + #:trusted trust-me #:name *list/c-name-proc #:first-order *list/c-first-order #:generate *list/c-generate @@ -1037,6 +1051,7 @@ (struct impersonator-*list/c *list-ctc () #:property prop:contract (build-contract-property + #:trusted trust-me #:name *list/c-name-proc #:first-order *list/c-first-order #:generate *list/c-generate @@ -1081,6 +1096,7 @@ (struct flat-ellipsis-rest-arg ellipsis-rest-arg-ctc () #:property prop:contract (build-contract-property + #:trusted trust-me #:name (λ (ctc) (error 'flat-ellipsis-rest-arg "the name property shouldn't be called!")) #:first-order *list/c-first-order #:generate *list/c-generate @@ -1093,6 +1109,7 @@ (struct chaperone-ellipsis-rest-arg ellipsis-rest-arg-ctc () #:property prop:contract (build-contract-property + #:trusted trust-me #:name (λ (ctc) (error 'flat-ellipsis-rest-arg "the name property shouldn't be called!")) #:first-order *list/c-first-order #:generate *list/c-generate @@ -1105,6 +1122,7 @@ (struct impersonator-ellipsis-rest-arg ellipsis-rest-arg-ctc () #:property prop:contract (build-contract-property + #:trusted trust-me #:name (λ (ctc) (error 'flat-ellipsis-rest-arg "the name property shouldn't be called!")) #:first-order *list/c-first-order #:generate *list/c-generate diff -Nru racket-7.2+ppa2/collects/racket/contract/private/misc.rkt racket-7.3+ppa1/collects/racket/contract/private/misc.rkt --- racket-7.2+ppa2/collects/racket/contract/private/misc.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/contract/private/misc.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -191,6 +191,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property + #:trusted trust-me #:name (λ (ctc) (cond @@ -236,6 +237,7 @@ (define (make-/c-contract-property name -/+ less/greater) (build-flat-contract-property + #:trusted trust-me #:name (λ (c) (cond [(renamed-<-ctc? c) (renamed-<-ctc-name c)] @@ -378,6 +380,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property + #:trusted trust-me #:name (λ (ctc) (build-compound-type-name 'syntax/c (syntax-ctc-ctc ctc))) #:stronger (λ (this that) (and (syntax-ctc? that) @@ -472,6 +475,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract (build-chaperone-contract-property + #:trusted trust-me #:name promise-contract-name #:late-neg-projection promise-contract-late-neg-proj #:stronger promise-ctc-stronger? @@ -482,6 +486,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property + #:trusted trust-me #:name promise-contract-name #:late-neg-projection promise-contract-late-neg-proj #:stronger promise-ctc-stronger? @@ -508,6 +513,7 @@ #:omit-define-syntaxes #:property prop:contract (build-contract-property + #:trusted trust-me #:late-neg-projection (λ (ctc) (define in-proc (get/build-late-neg-projection (parameter/c-in ctc))) @@ -571,6 +577,7 @@ #:omit-define-syntaxes #:property prop:flat-contract (build-flat-contract-property + #:trusted trust-me #:stronger procedure-arity-includes-equivalent? #:equivalent procedure-arity-includes-equivalent? #:name (λ (ctc) `(procedure-arity-includes/c ,(procedure-arity-includes/c-n ctc))) @@ -648,6 +655,7 @@ #:property prop:any/c #f #:property prop:flat-contract (build-flat-contract-property + #:trusted trust-me #:late-neg-projection (λ (ctc) any/c-blame->neg-party-fn) #:stronger (λ (this that) (any/c? that)) #:equivalent (λ (this that) (any/c? that)) @@ -676,6 +684,7 @@ #:omit-define-syntaxes #:property prop:flat-contract (build-flat-contract-property + #:trusted trust-me #:late-neg-projection none-curried-late-neg-proj #:stronger (λ (this that) #t) #:equivalent (λ (this that) (none/c? that)) @@ -784,6 +793,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract (build-chaperone-contract-property + #:trusted trust-me #:late-neg-projection (prompt-tag/c-late-neg-proj #t) #:first-order (λ (ctc) continuation-prompt-tag?) #:stronger prompt-tag/c-stronger? @@ -794,6 +804,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property + #:trusted trust-me #:late-neg-projection (prompt-tag/c-late-neg-proj #f) #:first-order (λ (ctc) continuation-prompt-tag?) #:stronger prompt-tag/c-stronger? @@ -863,6 +874,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract (build-chaperone-contract-property + #:trusted trust-me #: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? @@ -875,6 +887,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property + #:trusted trust-me #: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? @@ -956,6 +969,7 @@ (define-struct chaperone-evt/c (ctcs) #:property prop:chaperone-contract (build-chaperone-contract-property + #:trusted trust-me #:late-neg-projection evt/c-proj #:first-order evt/c-first-order #:stronger evt/c-stronger? @@ -1030,6 +1044,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract (build-chaperone-contract-property + #:trusted trust-me #:late-neg-projection (channel/c-late-neg-proj chaperone-channel) #:first-order channel/c-first-order #:stronger channel/c-stronger? @@ -1041,6 +1056,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property + #:trusted trust-me #:late-neg-projection (channel/c-late-neg-proj impersonate-channel) #:first-order channel/c-first-order #:stronger channel/c-stronger? @@ -1178,6 +1194,7 @@ (define-struct (chaperone-if/c base-if/c) () #:property prop:chaperone-contract (build-chaperone-contract-property + #:trusted trust-me #:late-neg-projection if/c-late-neg-proj #:first-order if/c-first-order #:name if/c-name)) @@ -1185,6 +1202,7 @@ (define-struct (impersonator-if/c base-if/c) () #:property prop:contract (build-contract-property + #:trusted trust-me #:late-neg-projection if/c-late-neg-proj #:first-order if/c-first-order #:name if/c-name)) diff -Nru racket-7.2+ppa2/collects/racket/contract/private/object.rkt racket-7.3+ppa1/collects/racket/contract/private/object.rkt --- racket-7.2+ppa2/collects/racket/contract/private/object.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/contract/private/object.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -57,6 +57,7 @@ #:omit-define-syntaxes #:property prop:contract (build-contract-property + #:trusted trust-me #:late-neg-projection (λ (ctc) (define flds (object-contract-fields ctc)) @@ -122,6 +123,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property + #:trusted trust-me #:first-order (λ (ctc) (define % (subclass/c-% ctc)) (λ (x) (subclass? x %))) #:stronger (λ (this that) (cond @@ -141,6 +143,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property + #:trusted trust-me #:first-order (λ (ctc) (define <%> (implementation/c-<%> ctc)) (λ (x) (implementation? x <%>))) #:stronger (λ (this that) (cond @@ -173,6 +176,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property + #:trusted trust-me #:first-order (λ (ctc) (define <%> (is-a?-ctc-<%> ctc)) @@ -249,4 +253,3 @@ 'is-a?/c (format "~s" '(or/c interface? class?)) <%>))) - \ No newline at end of file diff -Nru racket-7.2+ppa2/collects/racket/contract/private/opt.rkt racket-7.3+ppa1/collects/racket/contract/private/opt.rkt --- racket-7.2+ppa2/collects/racket/contract/private/opt.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/contract/private/opt.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -379,6 +379,7 @@ (λ (val port mode) (fprintf port "#" (opt-contract-name val))) #:property prop:flat-contract (build-flat-contract-property + #:trusted trust-me #:projection (λ (ctc) ((opt-contract-proj ctc) ctc)) #:first-order (λ (ctc) (flat-opt-contract-predicate ctc)) #:name (λ (ctc) (opt-contract-name ctc)) diff -Nru racket-7.2+ppa2/collects/racket/contract/private/orc.rkt racket-7.3+ppa1/collects/racket/contract/private/orc.rkt --- racket-7.2+ppa2/collects/racket/contract/private/orc.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/contract/private/orc.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -228,6 +228,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract (build-chaperone-contract-property + #:trusted trust-me #:late-neg-projection single-or/c-late-neg-projection #:name single-or/c-name #:first-order single-or/c-first-order @@ -243,6 +244,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property + #:trusted trust-me #:late-neg-projection single-or/c-late-neg-projection #:name single-or/c-name #:first-order single-or/c-first-order @@ -358,6 +360,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract (build-chaperone-contract-property + #:trusted trust-me #:late-neg-projection multi-or/c-late-neg-proj #:name multi-or/c-name #:first-order multi-or/c-first-order @@ -373,6 +376,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property + #:trusted trust-me #:late-neg-projection multi-or/c-late-neg-proj #:name multi-or/c-name #:first-order multi-or/c-first-order @@ -390,6 +394,7 @@ (λ (this) (flat-or/c-flat-ctcs this)) #:property prop:flat-contract (build-flat-contract-property + #:trusted trust-me #:name (λ (ctc) (apply build-compound-type-name @@ -495,6 +500,7 @@ (define-struct (chaperone-first-or/c base-first-or/c) () #:property prop:chaperone-contract (build-chaperone-contract-property + #:trusted trust-me #:late-neg-projection first-or/c-late-neg-proj #:name first-or/c-name #:first-order first-or/c-first-order @@ -506,6 +512,7 @@ (define-struct (impersonator-first-or/c base-first-or/c) () #:property prop:contract (build-contract-property + #:trusted trust-me #:late-neg-projection first-or/c-late-neg-proj #:name first-or/c-name #:first-order first-or/c-first-order @@ -546,6 +553,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property + #:trusted trust-me #:name (λ (ctc) (flat-rec-contract-name ctc)) #:stronger diff -Nru racket-7.2+ppa2/collects/racket/contract/private/parametric.rkt racket-7.3+ppa1/collects/racket/contract/private/parametric.rkt --- racket-7.2+ppa2/collects/racket/contract/private/parametric.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/contract/private/parametric.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -32,6 +32,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property + #:trusted trust-me #:name (lambda (c) `(parametric->/c ,(polymorphic-contract-vars c) ,(polymorphic-contract-body-src-exp c))) @@ -119,6 +120,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property + #:trusted trust-me #:name (lambda (c) (barrier-contract-name c)) #:first-order (λ (c) (barrier-contract-pred c)) #:stronger (λ (this that) (eq? this that)) diff -Nru racket-7.2+ppa2/collects/racket/contract/private/prop.rkt racket-7.3+ppa1/collects/racket/contract/private/prop.rkt --- racket-7.2+ppa2/collects/racket/contract/private/prop.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/contract/private/prop.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -13,6 +13,8 @@ contract-struct-late-neg-projection contract-struct-collapsible-late-neg-projection contract-struct-stronger? + trusted-contract-struct? + trusted-contract-struct-stronger? contract-struct-equivalent? contract-struct-generate contract-struct-exercise @@ -52,7 +54,9 @@ prop:any/c prop:any/c? - build-context) + build-context + + (protect-out trust-me)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -70,8 +74,8 @@ val-first-projection late-neg-projection collapsible-late-neg-projection - list-contract? ] - #:omit-define-syntaxes) + list-contract? ]) +(define-struct (trusted-contract-property contract-property) ()) (define (contract-property-guard prop info) (unless (contract-property? prop) @@ -86,6 +90,11 @@ (define-values [ prop:contract contract-struct? contract-struct-property ] (make-struct-type-property 'prop:contract contract-property-guard)) +;; determines if `c` is a contract that is trusted +(define (trusted-contract-struct? c) + (and (contract-struct? c) + (trusted-contract-property? (contract-struct-property c)))) + (define (contract-struct-name c) (let* ([prop (contract-struct-property c)] [get-name (contract-property-name prop)] @@ -121,6 +130,7 @@ (and get-collapsible-projection (get-collapsible-projection c))) +(define only-trusted? (make-parameter #f)) (define (contract-struct-stronger/equivalent? a b trail @@ -132,6 +142,9 @@ (chaperone-contract-struct? a)) (equal? a b)) #t] + [(and (only-trusted?) + (not (trusted-contract-struct? a))) + #f] [else (define prop (contract-struct-property a)) (define stronger/equivalent? (contract-property-stronger/equivalent prop)) @@ -193,6 +206,12 @@ contract-property-stronger #t)) +;; determines if `a` is stronger than `b` but using +;; the contract-stronger method only on trusted contracts +(define (trusted-contract-struct-stronger? a b) + (parameterize ([only-trusted? #t]) + (contract-struct-stronger? a b))) + (define equivalent-trail (make-parameter #f)) (define (contract-struct-equivalent? a b) (contract-struct-stronger/equivalent? @@ -298,7 +317,7 @@ (define-logger racket/contract) -(define ((build-property mk default-name proc-name first-order? equivalent-equal?) +(define ((build-property mk trusted-mk default-name proc-name first-order? equivalent-equal?) #:name [get-name #f] #:first-order [get-first-order #f] #:projection [get-projection #f] @@ -309,7 +328,8 @@ #:equivalent [equivalent #f] #:generate [generate (λ (ctc) (λ (fuel) #f))] #:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))] - #:list-contract? [list-contract? (λ (c) #f)]) + #:list-contract? [list-contract? (λ (c) #f)] + #:trusted [trusted #f]) (unless (or get-first-order get-projection get-val-first-projection @@ -340,7 +360,8 @@ " in the #:list-contract? argument") list-contract?)) - (mk (or get-name (λ (c) default-name)) + ((if (equal? trusted trust-me) trusted-mk mk) + (or get-name (λ (c) default-name)) (or get-first-order get-any?) get-projection (or stronger weakest) @@ -358,6 +379,8 @@ get-collapsible-late-neg-projection list-contract?)) +(define trust-me (gensym 'trustme)) + (define (build-context) (apply string-append @@ -367,18 +390,21 @@ (define build-contract-property (procedure-rename - (build-property make-contract-property 'anonymous-contract 'build-contract-property #f #f) + (build-property make-contract-property make-trusted-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) + (compose make-flat-contract-property make-trusted-contract-property) 'anonymous-flat-contract 'build-flat-contract-property #t #t) 'build-flat-contract-property)) (define build-chaperone-contract-property (procedure-rename (build-property (compose make-chaperone-contract-property make-contract-property) + (compose make-chaperone-contract-property make-trusted-contract-property) 'anonymous-chaperone-contract 'build-chaperone-contract-property #f #t) 'build-chaperone-contract-property)) diff -Nru racket-7.2+ppa2/collects/racket/contract/private/provide.rkt racket-7.3+ppa1/collects/racket/contract/private/provide.rkt --- racket-7.2+ppa2/collects/racket/contract/private/provide.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/contract/private/provide.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -460,6 +460,8 @@ [(_ p/c-ele ...) (let () + (define mangled-id-scope (make-syntax-introducer)) + ;; ids : table[id -o> (listof id)] ;; code-for-each-clause adds identifiers to this map. ;; when it binds things; they are then used to signal @@ -710,9 +712,10 @@ #t))] [mutator-ids (reverse (list-ref the-struct-info 4))] ;; (listof (union #f identifier)) [field-contract-ids (map (λ (field-name field-contract) - (a:mangle-id "provide/contract-field-contract" - field-name - struct-name)) + (mangled-id-scope + (a:mangle-id "provide/contract-field-contract" + field-name + struct-name))) field-names field-contracts)] [struct:struct-name @@ -1083,11 +1086,12 @@ (syntax code))) (define (id-for-one-id user-rename-id reflect-id id [mangle-for-maker? #f]) - ((if mangle-for-maker? - a:mangle-id-for-maker - a:mangle-id) - "provide/contract-id" - (or user-rename-id reflect-id id))) + (mangled-id-scope + ((if mangle-for-maker? + a:mangle-id-for-maker + a:mangle-id) + "provide/contract-id" + (or user-rename-id reflect-id id)))) (define pos-module-source-id ;; Avoid context on this identifier, since it will be defined @@ -1118,8 +1122,9 @@ (free-identifier-mapping-put! struct-id-mapping a - (a:mangle-id "provide/contract-struct-expandsion-info-id" - a)) + (mangled-id-scope + (a:mangle-id "provide/contract-struct-expansion-info-id" + a))) (define parent-selectors (if parent (let ([parent-selectors (list-ref (extract-struct-info (syntax-local-value parent)) diff -Nru racket-7.2+ppa2/collects/racket/contract/private/struct-dc.rkt racket-7.3+ppa1/collects/racket/contract/private/struct-dc.rkt --- racket-7.2+ppa2/collects/racket/contract/private/struct-dc.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/contract/private/struct-dc.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -733,6 +733,7 @@ (define-struct (struct/dc base-struct/dc) () #:property prop:chaperone-contract (build-chaperone-contract-property + #:trusted trust-me #:name struct/dc-name #:first-order struct/dc-first-order #:late-neg-projection struct/dc-late-neg-proj @@ -744,6 +745,7 @@ (define-struct (flat-struct/dc base-struct/dc) () #:property prop:flat-contract (build-flat-contract-property + #:trusted trust-me #:name struct/dc-name #:first-order struct/dc-flat-first-order #:late-neg-projection struct/dc-late-neg-proj @@ -755,6 +757,7 @@ (define-struct (impersonator-struct/dc base-struct/dc) () #:property prop:contract (build-contract-property + #:trusted trust-me #:name struct/dc-name #:first-order struct/dc-first-order #:late-neg-projection struct/dc-late-neg-proj @@ -1071,6 +1074,10 @@ (values info #'id all-clauses))])) +(define-for-syntax (disarm stx) + (syntax-disarm stx (variable-reference->module-declaration-inspector + (#%variable-reference)))) + ;; name->sel-id : identifier syntax -> identifier ;; returns the identifier for the selector, where the 'id' ;; argument is either an identifier or a #'(id #:parent id) @@ -1078,7 +1085,7 @@ (define-for-syntax (name->sel-id struct-id id) (define (combine struct-id id) (datum->syntax - id + (disarm id) (string->symbol (format "~a-~a" (syntax-e struct-id) @@ -1096,7 +1103,7 @@ (define-for-syntax (name->mut-id stx struct-id id) (define (combine struct-id id) (datum->syntax - id + (disarm id) (string->symbol (format "set-~a-~a!" (syntax-e struct-id) @@ -1565,7 +1572,7 @@ (regexp (format "^~a-" (regexp-quote (symbol->string (syntax-e struct-id)))))) (define field-name (datum->syntax - sel + (disarm sel) (string->symbol (regexp-replace strip-reg (symbol->string (syntax-e sel)) "")))) diff -Nru racket-7.2+ppa2/collects/racket/contract/private/struct-prop.rkt racket-7.3+ppa1/collects/racket/contract/private/struct-prop.rkt --- racket-7.2+ppa2/collects/racket/contract/private/struct-prop.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/contract/private/struct-prop.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1,8 +1,12 @@ #lang racket/base (require "guts.rkt" "blame.rkt" - "prop.rkt") -(provide (rename-out [struct-type-property/c* struct-type-property/c])) + "prop.rkt" + "base.rkt" + (for-syntax racket/base) + syntax/location) +(provide (rename-out [struct-type-property/c* struct-type-property/c]) + struct-guard/c) (define (get-stpc-late-neg-proj stpc) (define get-late-neg-proj @@ -34,6 +38,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property + #:trusted trust-me #:name (lambda (c) (build-compound-type-name 'struct-type-property/c @@ -47,3 +52,61 @@ (struct-type-property/c (coerce-contract 'struct-type-property/c value-contract)))]) struct-type-property/c)) + +(define-syntax (struct-guard/c stx) + (syntax-case stx () + [(_ . args) + #`(struct-guard/c/proc (quote-srcloc #,stx) + (current-contract-region) + . args)])) + +(define (struct-guard/c/proc loc blame-party . ctc-args) + (define ctcs + (for/list ([arg (in-list ctc-args)] + [i (in-naturals)]) + (define ctc (coerce-contract/f arg)) + (unless ctc + (apply raise-argument-error + 'struct-guard/c + "contract?" + i + ctc-args)) + ctc)) + + ;; don't want to depend on racket/list, so duplicate this + ;; (plus we know that it will always be a non-empty list, + ;; so skip some checks) + (define (last l) + (let loop ([l l]) + (if (pair? (cdr l)) (loop (cdr l)) (car l)))) + + (define number-of-contracts (length ctcs)) + + ;; would like to have this be specialized to the number of + ;; arguments there actually are, but given the fact that + ;; we're creating blame objects and projections after getting + ;; the arguments it doesn't seem worth bothering for now + ;; (we are creating the projections late because we don't + ;; get the `name` until later on) + (λ args + (define name (last args)) + (unless (= (length args) (+ number-of-contracts 1)) + (error 'struct-guard/c + "given ~a contracts, but the struct ~s has ~a fields" + number-of-contracts + name + (- (length args) 1))) + (define ctc-projs + (for/list ([ctc (in-list ctcs)] + [i (in-naturals 1)]) + (make-apply-contract ctc + blame-party blame-party + (if (= number-of-contracts 1) + name + (format "~a, field ~a" name i)) + loc + #f))) + (apply values + (for/list ([arg (in-list args)] + [proj (in-list ctc-projs)]) + (proj arg))))) diff -Nru racket-7.2+ppa2/collects/racket/contract/private/unconstrained-domain-arrow.rkt racket-7.3+ppa1/collects/racket/contract/private/unconstrained-domain-arrow.rkt --- racket-7.2+ppa2/collects/racket/contract/private/unconstrained-domain-arrow.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/contract/private/unconstrained-domain-arrow.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -112,6 +112,7 @@ #:property prop:chaperone-contract (build-chaperone-contract-property + #:trusted trust-me #:name unconstrained-domain->-name #:first-order unconstrained-domain->-first-order #:late-neg-projection unconstrained-domain->-projection @@ -121,6 +122,7 @@ #:property prop:chaperone-contract (build-chaperone-contract-property + #:trusted trust-me #:name unconstrained-domain->-name #:first-order unconstrained-domain->-first-order #:late-neg-projection unconstrained-domain->-projection diff -Nru racket-7.2+ppa2/collects/racket/contract/private/vector.rkt racket-7.3+ppa1/collects/racket/contract/private/vector.rkt --- racket-7.2+ppa2/collects/racket/contract/private/vector.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/contract/private/vector.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -134,6 +134,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property + #:trusted trust-me #:name vectorof-name #:first-order vectorof-first-order #:late-neg-projection (λ (ctc) @@ -315,6 +316,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract (build-chaperone-contract-property + #:trusted trust-me #:name vectorof-name #:first-order vectorof-first-order #:equivalent vectorof-equivalent @@ -325,6 +327,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property + #:trusted trust-me #:name vectorof-name #:first-order vectorof-first-order #:equivalent vectorof-equivalent @@ -458,6 +461,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:flat-contract (build-flat-contract-property + #:trusted trust-me #:name vector/c-name #:first-order vector/c-first-order #:stronger vector/c-stronger @@ -646,6 +650,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:chaperone-contract (build-chaperone-contract-property + #:trusted trust-me #:name vector/c-name #:first-order vector/c-first-order #:stronger vector/c-stronger @@ -656,6 +661,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property + #:trusted trust-me #:name vector/c-name #:first-order vector/c-first-order #:stronger vector/c-stronger diff -Nru racket-7.2+ppa2/collects/racket/fasl.rkt racket-7.3+ppa1/collects/racket/fasl.rkt --- racket-7.2+ppa2/collects/racket/fasl.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/fasl.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -195,10 +195,18 @@ (write-fasl-integer v o)])] [(flonum? v) (write-byte fasl-flonum-type o) - (write-bytes (real->floating-point-bytes v 8 #f) o)] + (write-bytes (if (eqv? v +nan.0) + ;; use a canonical NaN (0 mantissa) + #"\0\0\0\0\0\0\370\177" + (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)] + (write-bytes (if (eqv? v +nan.f) + ;; use a canonical NaN (0 mantissa) + #"\0\0\300\177" + (real->floating-point-bytes v 4 #f)) + o)] [(extflonum? v) (write-byte fasl-extflonum-type o) (define bstr (string->bytes/utf-8 (format "~a" v))) diff -Nru racket-7.2+ppa2/collects/racket/HISTORY.txt racket-7.3+ppa1/collects/racket/HISTORY.txt --- racket-7.2+ppa2/collects/racket/HISTORY.txt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/HISTORY.txt 2019-05-16 01:29:07.000000000 +0000 @@ -1,3 +1,6 @@ +Version 7.3, May 2019 +Bug repairs and other changes noted in the documentation + Version 7.2, January 2019 Bug repairs and other changes noted in the documentation diff -Nru racket-7.2+ppa2/collects/racket/linklet.rkt racket-7.3+ppa1/collects/racket/linklet.rkt --- racket-7.2+ppa2/collects/racket/linklet.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/linklet.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -64,8 +64,8 @@ (define (correlated? e) (syntax? e)) -(define (datum->correlated d [srcloc #f]) - (datum->syntax #f d srcloc)) +(define (datum->correlated d [srcloc #f] [props #f]) + (datum->syntax #f d srcloc props)) (define (correlated-e e) (syntax-e e)) diff -Nru racket-7.2+ppa2/collects/racket/math.rkt racket-7.3+ppa1/collects/racket/math.rkt --- racket-7.2+ppa2/collects/racket/math.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/math.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -65,18 +65,29 @@ [else (/ (+ (exp z) (exp (- z))) 2)])) (define (tanh z) + ;implementation based on https://www.math.utah.edu/~beebe/software/ieee/tanh.pdf (unless (number? z) (raise-argument-error 'tanh "number?" z)) (cond [(= z 0) z] ; preserve 0, 0.0, -0.0, 0.0f0, 0.0+0.0i, etc. [(real? z) (let loop ([z z]) (cond [(z . < . 0) (- (loop (- z)))] - [(z . < . 20) (define exp2z (exp (* 2 z))) - (/ (- exp2z 1) (+ exp2z 1))] - [(z . >= . 20) (if (single-flonum? z) 1.0f0 1.0)] + [(z . < . 1.29047841397589243466D-08) z] + [(z . < . 0.54930614433405484570D+00) + (define p0 -0.16134119023996228053D+04) + (define p1 -0.99225929672236083313D+02) + (define p2 -0.96437492777225469787D+00) + (define q0 0.48402357071988688686D+04) + (define q1 0.22337720718962312926D+04) + (define q2 0.11274474380534949335D+03) + (define g (* z z)) + (define R + (/ (* g (+ (* (+ (* p2 g) p1) g) p0)) + (+ (* (+ (* (+ g q2) g) q1) g) q0))) + (+ z (* z R))] + [(z . < . 19.06154746539849600897D+00) (- 1 (/ 2 (+ 1 (exp (* 2 z)))))] + [(z . >= . 19.06154746539849600897D+00) (if (single-flonum? z) 1.0f0 1.0)] [else z]))] ; +nan.0 or +nan.f - [else - (define exp2z (exp (* 2 z))) - (/ (- exp2z 1) (+ exp2z 1))])) + [else (- 1 (/ 2 (+ 1 (exp (* 2 z)))))])) ;; angle conversion (define (degrees->radians x) diff -Nru racket-7.2+ppa2/collects/racket/port.rkt racket-7.3+ppa1/collects/racket/port.rkt --- racket-7.2+ppa2/collects/racket/port.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/port.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -863,7 +863,7 @@ (thread-resume mgr-th (current-thread)) (channel-put mgr-ch (list* what ch nack req-sfx)) (wrap-evt ch (lambda (x) - (if (eq? x 'close) + (if (eq? x 'closed) (raise-mismatch-error 'write-evt "port is closed: " out) x))))))))) (define (resume-mgr) diff -Nru racket-7.2+ppa2/collects/racket/pretty.rkt racket-7.3+ppa1/collects/racket/pretty.rkt --- racket-7.2+ppa2/collects/racket/pretty.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/pretty.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -482,7 +482,10 @@ (and (custom-write? obj) (not (struct-type? obj))) (and (struct? obj) print-struct?) - (and (hash? obj) print-hash-table?)) + (and (hash? obj) + (not (and (zero? (hash-count obj)) + (immutable? obj))) + print-hash-table?)) (or (hash-ref table obj #f) (begin (hash-set! table obj #t) @@ -525,7 +528,10 @@ (and (custom-write? obj) (not (struct-type? obj))) (and (struct? obj) print-struct?) - (and (hash? obj) print-hash-table?)) + (and (hash? obj) + (not (and (zero? (hash-count obj)) + (immutable? obj))) + print-hash-table?)) ;; A little confusing: use #t for not-found (let ([p (hash-ref table obj #t)]) (when (not (mark? p)) @@ -634,7 +640,9 @@ (not (prefab-struct-key obj))) (escapes! obj))] [(hash? obj) - (is-compound! obj) + (unless (and (zero? (hash-count obj)) + (immutable? obj)) + (is-compound! obj)) (and (for/fold ([esc? #f]) ([(k v) (in-hash obj)]) (or (orf (loop v) (loop k)) diff -Nru racket-7.2+ppa2/collects/racket/private/case.rkt racket-7.3+ppa1/collects/racket/private/case.rkt --- racket-7.2+ppa2/collects/racket/private/case.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/private/case.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -12,24 +12,29 @@ (define-syntax (case stx) (syntax-case stx (else) ;; Empty case - [(_ v) (syntax/loc stx (#%expression (begin v (void))))] + [(_ v) + (syntax-protect + (syntax/loc stx (#%expression (begin v (void)))))] ;; Else-only case [(_ v [else e es ...]) - (syntax/loc stx (#%expression (begin v (let-values () e es ...))))] + (syntax-protect + (syntax/loc stx (#%expression (begin v (let-values () e es ...)))))] ;; If we have a syntactically correct form without an 'else' clause, ;; add the default 'else' and try again. [(self v [(k ...) e1 e2 ...] ...) - (syntax/loc stx (self v [(k ...) e1 e2 ...] ... [else (void)]))] + (syntax-protect + (syntax/loc stx (self v [(k ...) e1 e2 ...] ... [else (void)])))] ;; The general case [(_ v [(k ...) e1 e2 ...] ... [else x1 x2 ...]) - (if (< (length (syntax-e #'(k ... ...))) *sequential-threshold*) - (syntax/loc stx (let ([tmp v]) - (case/sequential tmp [(k ...) e1 e2 ...] ... [else x1 x2 ...]))) - (syntax/loc stx (let ([tmp v]) - (case/dispatch tmp [(k ...) e1 e2 ...] ... [else x1 x2 ...]))))] + (syntax-protect + (if (< (length (syntax-e #'(k ... ...))) *sequential-threshold*) + (syntax/loc stx (let ([tmp v]) + (case/sequential tmp [(k ...) e1 e2 ...] ... [else x1 x2 ...]))) + (syntax/loc stx (let ([tmp v]) + (case/dispatch tmp [(k ...) e1 e2 ...] ... [else x1 x2 ...])))))] ;; Error cases [(_ v clause ...) @@ -62,7 +67,28 @@ [(bad . _) (raise-syntax-error #f - "bad syntax (not a datum sequence)" + ;; If #'bad is an identifier, report its binding in the error message. + ;; This helps resolving the syntax error when `else' is shadowed somewhere + (if (not (symbol? (syntax-e (syntax bad)))) + "bad syntax (not a datum sequence)" + (string-append + "bad syntax (not a datum sequence)\n" + " expected: a datum sequence or the binding 'else' from racket/base\n" + " given: " + (let ([binding (identifier-binding (syntax bad))]) + (cond + [(not binding) "an unbound identifier"] + [(eq? binding 'lexical) "a locally bound identifier"] + [else + (let*-values ([(src) (car binding)] + [(mpath base) (module-path-index-split src)]) + (cond + [(not mpath) + "an identifier bound by the current module"] + [else + (format "an identifier required from the module ~a" + (resolved-module-path-name + (module-path-index-resolve src)))]))])))) stx (syntax bad))] [_ @@ -83,23 +109,27 @@ (define-syntax (case/sequential stx) (syntax-case stx (else) [(_ v [(k ...) es ...] arms ... [else xs ...]) - #'(if (case/sequential-test v (k ...)) - (let-values () es ...) - (case/sequential v arms ... [else xs ...]))] + (syntax-protect + #'(if (case/sequential-test v (k ...)) + (let-values () es ...) + (case/sequential v arms ... [else xs ...])))] [(_ v [(k ...) es ...] [else xs ...]) - #'(if (case/sequential-test v (k ...)) - (let-values () es ...) - (let-values () xs ...))] + (syntax-protect + #'(if (case/sequential-test v (k ...)) + (let-values () es ...) + (let-values () xs ...)))] [(_ v [else xs ...]) - #'(let-values () xs ...)])) + (syntax-protect + #'(let-values () xs ...))])) (define-syntax (case/sequential-test stx) - (syntax-case stx () - [(_ v ()) #'#f] - [(_ v (k)) #`(equal? v 'k)] - [(_ v (k ks ...)) #`(if (equal? v 'k) - #t - (case/sequential-test v (ks ...)))])) + (syntax-protect + (syntax-case stx () + [(_ v ()) #'#f] + [(_ v (k)) #`(equal? v 'k)] + [(_ v (k ks ...)) #`(if (equal? v 'k) + #t + (case/sequential-test v (ks ...)))]))) ;; Triple-dispatch case: ;; (1) From the type of the value to a type-specific mechanism for @@ -109,29 +139,30 @@ (define-syntax (case/dispatch stx) (syntax-case stx (else) [(_ v [(k ...) es ...] ... [else xs ...]) - #`(let ([index - #,(let* ([ks (partition-constants #'((k ...) ...))] - [exp #'0] - [exp (if (null? (consts-other ks)) - exp - (dispatch-other #'v (consts-other ks) exp))] - [exp (if (null? (consts-char ks)) - exp - #`(if (char? v) - #,(dispatch-char #'v (consts-char ks)) - #,exp))] - [exp (if (null? (consts-symbol ks)) - exp - #`(if #,(test-for-symbol #'v (consts-symbol ks)) - #,(dispatch-symbol #'v (consts-symbol ks) #'0) - #,exp))] - [exp (if (null? (consts-fixnum ks)) - exp - #`(if (fixnum? v) - #,(dispatch-fixnum #'v (consts-fixnum ks)) - #,exp))]) - exp)]) - #,(index-binary-search #'index #'([xs ...] [es ...] ...)))])) + (syntax-protect + #`(let ([index + #,(let* ([ks (partition-constants #'((k ...) ...))] + [exp #'0] + [exp (if (null? (consts-other ks)) + exp + (dispatch-other #'v (consts-other ks) exp))] + [exp (if (null? (consts-char ks)) + exp + #`(if (char? v) + #,(dispatch-char #'v (consts-char ks)) + #,exp))] + [exp (if (null? (consts-symbol ks)) + exp + #`(if #,(test-for-symbol #'v (consts-symbol ks)) + #,(dispatch-symbol #'v (consts-symbol ks) #'0) + #,exp))] + [exp (if (null? (consts-fixnum ks)) + exp + #`(if (fixnum? v) + #,(dispatch-fixnum #'v (consts-fixnum ks)) + #,exp))]) + exp)]) + #,(index-binary-search #'index #'([xs ...] [es ...] ...))))])) (begin-for-syntax diff -Nru racket-7.2+ppa2/collects/racket/private/class-c-old.rkt racket-7.3+ppa1/collects/racket/private/class-c-old.rkt --- racket-7.2+ppa2/collects/racket/private/class-c-old.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/private/class-c-old.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -9,6 +9,7 @@ "../contract/base.rkt" "../contract/combinator.rkt" (only-in "../contract/private/arrow-val-first.rkt" ->-internal ->*-internal) + (only-in "../contract/private/prop.rkt" trust-me) (only-in "../contract/private/case-arrow.rkt" case->-internal) (only-in "../contract/private/arr-d.rkt" ->d-internal) (submod "../contract/private/collapsible-common.rkt" properties)) @@ -427,7 +428,7 @@ handled-args (let-values ([(prefix suffix) (grab-same-inits inits/c)]) (loop suffix - (apply-init-contracts prefix init-args)))))]) + (apply-init-contracts prefix handled-args)))))]) ;; Since we never consume init args, we can ignore si_leftovers ;; since init-args is the same. (if never-wrapped? @@ -768,53 +769,15 @@ ;; Unlike the others, we always want to do this, even if there are no init contracts, ;; since we still need to handle either calling the previous class/c's init or ;; calling continue-make-super appropriately. - (let () - ;; grab all the inits+contracts that involve the same init arg - ;; (assumes that inits and contracts were sorted in class/c creation) - (define (grab-same-inits lst) - (if (null? lst) - (values null null) - (let loop ([inits/c (cdr lst)] - [prefix (list (car lst))]) - (cond - [(null? inits/c) - (values (reverse prefix) inits/c)] - [(eq? (list-ref (car inits/c) 0) (list-ref (car prefix) 0)) - (loop (cdr inits/c) - (cons (car inits/c) prefix))] - [else (values (reverse prefix) inits/c)])))) - ;; run through the list of init-args and apply contracts for same-named - ;; init args - (define (apply-init-contracts inits/c init-args) - (let loop ([init-args init-args] - [inits/c inits/c] - [handled-args null]) - (cond - [(null? init-args) - (reverse handled-args)] - [(null? inits/c) - (append (reverse handled-args) init-args)] - [(eq? (list-ref (car inits/c) 0) (car (car init-args))) - (let ([init-arg (car init-args)] - [p (list-ref (car inits/c) 1)]) - (loop (cdr init-args) - (cdr inits/c) - (cons (cons (car init-arg) (if p - (p (cdr init-arg)) - (cdr init-arg))) - handled-args)))] - [else (loop (cdr init-args) - inits/c - (cons (car init-args) handled-args))]))) - (set-class-init! - c - (lambda (the-obj super-go si_c si_inited? si_leftovers init-args) - ;; Since we never consume init args, we can ignore si_leftovers - ;; since init-args is the same. - (if never-wrapped? - (super-go the-obj si_c si_inited? init-args null null) - (init the-obj super-go si_c si_inited? init-args init-args))))) - + (set-class-init! + c + (lambda (the-obj super-go si_c si_inited? si_leftovers init-args) + ;; Since we never consume init args, we can ignore si_leftovers + ;; since init-args is the same. + (if never-wrapped? + (super-go the-obj si_c si_inited? init-args null null) + (init the-obj super-go si_c si_inited? init-args init-args)))) + (copy-seals cls c))))) (define (blame-add-init-context blame name) @@ -1083,6 +1046,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property + #:trusted trust-me #:late-neg-projection class/c-late-neg-proj #:name build-class/c-name #:stronger class/c-stronger @@ -1522,7 +1486,8 @@ (define-struct base-instanceof/c (class-ctc) #:property prop:custom-write custom-write-property-proc #:property prop:contract - (build-contract-property + (build-contract-property + #:trusted trust-me #:late-neg-projection instanceof/c-late-neg-proj #:name (λ (ctc) @@ -1660,6 +1625,7 @@ #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property + #:trusted trust-me #:late-neg-projection instanceof/c-late-neg-proj #:name (λ (ctc) diff -Nru racket-7.2+ppa2/collects/racket/private/classidmap.rkt racket-7.3+ppa1/collects/racket/private/classidmap.rkt --- racket-7.2+ppa2/collects/racket/private/classidmap.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/private/classidmap.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -466,4 +466,5 @@ make-method-call-to-possibly-wrapped-object do-localize make-private-name generate-super-call generate-inner-call - generate-class-expand-context class-top-level-context?)) + generate-class-expand-context class-top-level-context? + class-syntax-protect)) diff -Nru racket-7.2+ppa2/collects/racket/private/class-internal.rkt racket-7.3+ppa1/collects/racket/private/class-internal.rkt --- racket-7.2+ppa2/collects/racket/private/class-internal.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/private/class-internal.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -32,52 +32,53 @@ ;; needed for Typed Racket (protect-out do-make-object find-method/who)) (define-syntax (provide-public-names stx) - (datum->syntax - stx - '(provide class class* class/derived - define-serializable-class define-serializable-class* - class? - mixin - interface interface* interface? - object% object? externalizable<%> printable<%> writable<%> equal<%> - object=? object-or-false=? object=-hash-code - new make-object instantiate - send send/apply send/keyword-apply send* send+ dynamic-send - class-field-accessor class-field-mutator with-method - get-field set-field! field-bound? field-names - dynamic-get-field dynamic-set-field! - private* public* pubment* - override* overment* - augride* augment* - public-final* override-final* augment-final* - define/private define/public define/pubment - define/override define/overment - define/augride define/augment - define/public-final define/override-final define/augment-final - define-local-member-name define-member-name - member-name-key generate-member-key - member-name-key? member-name-key=? member-name-key-hash-code - generic make-generic send-generic - is-a? subclass? implementation? interface-extension? - object-interface object-info object->vector - object-method-arity-includes? - method-in-interface? interface->method-names class->interface class-info - (struct-out exn:fail:object) - make-primitive-class - class/c ->m ->*m ->dm case->m object/c instanceof/c - dynamic-object/c - class-seal class-unseal - - ;; "keywords": - private public override augment - pubment overment augride - public-final override-final augment-final - field init init-field init-rest - rename-super rename-inner inherit inherit/super inherit/inner inherit-field - this this% super inner - super-make-object super-instantiate super-new - inspect absent abstract) - stx)) + (class-syntax-protect + (datum->syntax + stx + '(provide class class* class/derived + define-serializable-class define-serializable-class* + class? + mixin + interface interface* interface? + object% object? externalizable<%> printable<%> writable<%> equal<%> + object=? object-or-false=? object=-hash-code + new make-object instantiate + send send/apply send/keyword-apply send* send+ dynamic-send + class-field-accessor class-field-mutator with-method + get-field set-field! field-bound? field-names + dynamic-get-field dynamic-set-field! + private* public* pubment* + override* overment* + augride* augment* + public-final* override-final* augment-final* + define/private define/public define/pubment + define/override define/overment + define/augride define/augment + define/public-final define/override-final define/augment-final + define-local-member-name define-member-name + member-name-key generate-member-key + member-name-key? member-name-key=? member-name-key-hash-code + generic make-generic send-generic + is-a? subclass? implementation? interface-extension? + object-interface object-info object->vector + object-method-arity-includes? + method-in-interface? interface->method-names class->interface class-info + (struct-out exn:fail:object) + make-primitive-class + class/c ->m ->*m ->dm case->m object/c instanceof/c + dynamic-object/c + class-seal class-unseal + + ;; "keywords": + private public override augment + pubment overment augride + public-final override-final augment-final + field init init-field init-rest + rename-super rename-inner inherit inherit/super inherit/inner inherit-field + this this% super inner + super-make-object super-instantiate super-new + inspect absent abstract) + stx))) ;;-------------------------------------------------------------------- ;; keyword setup @@ -104,9 +105,10 @@ (if (identifier? e) e (syntax-property e 'taint-mode 'transparent)))]) - (syntax-property (syntax/loc stx (internal-id elem ...)) - 'taint-mode - 'transparent))])) + (class-syntax-protect + (syntax-property (syntax/loc stx (internal-id elem ...)) + 'taint-mode + 'transparent)))])) (define-syntax provide-renaming-class-keyword (syntax-rules () @@ -140,9 +142,10 @@ (syntax-case stx () [(_ elem ...) (with-syntax ([internal-id internal-id]) - (syntax-property (syntax/loc stx (internal-id elem ...)) - 'taint-mode - 'transparent))])) + (class-syntax-protect + (syntax-property (syntax/loc stx (internal-id elem ...)) + 'taint-mode + 'transparent)))])) (define-syntax provide-naming-class-keyword (syntax-rules () @@ -1530,6 +1533,7 @@ #'(current-inspector))] [deserialize-id-expr deserialize-id-expr] [private-field-names private-field-names]) + (class-syntax-protect (add-decl-props (quasisyntax/loc stx (detect-field-unsafe-undefined @@ -1712,7 +1716,7 @@ ;; Extra argument added here by `detect-field-unsafe-undefined` #; check-undef? ;; Not primitive: - #f)))))))))))))))) + #f))))))))))))))))) ;; The class* and class entry points: (values @@ -1772,36 +1776,39 @@ #`((runtime-require (submod "." deserialize-info)) (module+ deserialize-info (provide #,deserialize-name-info))) #'())]) - #'(begin - (define-values (name deserialize-name-info) - (class/derived orig-stx [name - super-expression - (interface-expr ...) - #'deserialize-name-info] - defn-or-expr ...)) - provision ...)))])) + (class-syntax-protect + #'(begin + (define-values (name deserialize-name-info) + (class/derived orig-stx [name + super-expression + (interface-expr ...) + #'deserialize-name-info] + defn-or-expr ...)) + provision ...))))])) (define-syntax (define-serializable-class* stx) (syntax-case stx () [(_ name super-expression (interface-expr ...) defn-or-expr ...) (with-syntax ([orig-stx stx]) - #'(-define-serializable-class orig-stx - name - super-expression - (interface-expr ...) - defn-or-expr ...))])) + (class-syntax-protect + #'(-define-serializable-class orig-stx + name + super-expression + (interface-expr ...) + defn-or-expr ...)))])) (define-syntax (define-serializable-class stx) (syntax-case stx () [(_ name super-expression defn-or-expr ...) (with-syntax ([orig-stx stx]) - #'(-define-serializable-class orig-stx - name - super-expression - () - defn-or-expr ...))])) + (class-syntax-protect + #'(-define-serializable-class orig-stx + name + super-expression + () + defn-or-expr ...)))])) (define-syntaxes (private* public* pubment* override* overment* augride* augment* public-final* override-final* augment-final*) @@ -1833,11 +1840,12 @@ (with-syntax ([(name ...) (map car name-exprs)] [(expr ...) (map cdr name-exprs)] [decl-form decl-form]) - (syntax - (begin - (decl-form name ...) - (define name expr) - ...)))))])))]) + (class-syntax-protect + (syntax + (begin + (decl-form name ...) + (define name expr) + ...))))))])))]) (values (mk 'private* (syntax private)) (mk 'public* (syntax public)) @@ -1910,11 +1918,12 @@ (define-syntaxes (id ...) (values (make-private-name (quote-syntax id) (quote-syntax gen-id)) ...)))]) - (syntax/loc stx - (begin - (define-values (gen-id ...) - (values (generate-local-member-name 'id) ...)) - stx-defs))))))])) + (class-syntax-protect + (syntax/loc stx + (begin + (define-values (gen-id ...) + (values (generate-local-member-name 'id) ...)) + stx-defs)))))))])) (define-syntax (define-member-name stx) (syntax-case stx () @@ -1932,9 +1941,10 @@ (define-syntax id (make-private-name (quote-syntax id) ((syntax-local-certifier) (quote-syntax member-name)))))]) - #'(begin - (define member-name (check-member-key 'id expr)) - stx-def)))])) + (class-syntax-protect + #'(begin + (define member-name (check-member-key 'id expr)) + stx-def))))])) (define (generate-local-member-name id) (string->uninterned-symbol @@ -1965,7 +1975,8 @@ [(_ id) (identifier? #'id) (with-syntax ([id (localize #'id)]) - (syntax/loc stx (make-member-key `id)))] + (class-syntax-protect + (syntax/loc stx (make-member-key `id))))] [(_ x) (raise-syntax-error #f @@ -3087,15 +3098,15 @@ (with-syntax ([name (datum->syntax #f name #f)] [(var ...) (map localize vars)] [((v c) ...) (filter (λ (p) (cadr p)) (map list vars ctcs))]) - (syntax/loc - stx - (compose-interface - 'name - (list interface-expr ...) - `(var ...) - (make-immutable-hash (list (cons 'v c) ...)) - (list prop ...) - (list prop-val ...)))))]))) + (class-syntax-protect + (syntax/loc stx + (compose-interface + 'name + (list interface-expr ...) + `(var ...) + (make-immutable-hash (list (cons 'v c) ...)) + (list prop ...) + (list prop-val ...))))))]))) (define-syntax (_interface stx) (syntax-case stx () @@ -3310,8 +3321,9 @@ (syntax-case stx () [(_ cls (id arg) ...) (andmap identifier? (syntax->list (syntax (id ...)))) - (quasisyntax/loc stx - (instantiate cls () (id arg) ...))] + (class-syntax-protect + (quasisyntax/loc stx + (instantiate cls () (id arg) ...)))] [(_ cls (id arg) ...) (for-each (lambda (id) (unless (identifier? id) @@ -3334,21 +3346,24 @@ (syntax-case stx () [id (identifier? #'id) - (quasisyntax/loc stx - (make-object/proc (current-contract-region)))] + (class-syntax-protect + (quasisyntax/loc stx + (make-object/proc (current-contract-region))))] [(_ class arg ...) - (quasisyntax/loc stx - (do-make-object - (current-contract-region) - class (list arg ...) (list)))] + (class-syntax-protect + (quasisyntax/loc stx + (do-make-object + (current-contract-region) + class (list arg ...) (list))))] [(_) (raise-syntax-error 'make-object "expected class" stx)])))) (define-syntax (instantiate stx) (syntax-case stx () [(form class (arg ...) . x) (with-syntax ([orig-stx stx]) - (quasisyntax/loc stx - (-instantiate do-make-object orig-stx #t (class) (list arg ...) . x)))])) + (class-syntax-protect + (quasisyntax/loc stx + (-instantiate do-make-object orig-stx #t (class) (list arg ...) . x))))])) ;; Helper; used by instantiate and super-instantiate (define-syntax -instantiate @@ -3358,12 +3373,13 @@ (andmap identifier? (syntax->list (syntax (kw ...)))) (with-syntax ([(kw ...) (map localize (syntax->list (syntax (kw ...))))] [(blame ...) (if (syntax-e #'first?) #'((current-contract-region)) null)]) - (syntax/loc stx - (do-make-object blame ... - maker-arg ... - args - (list (cons `kw arg) - ...))))] + (class-syntax-protect + (syntax/loc stx + (do-make-object blame ... + maker-arg ... + args + (list (cons `kw arg) + ...)))))] [(_ super-make-object orig-stx first? (make-arg ...) args kwarg ...) ;; some kwarg must be bad: (for-each (lambda (kwarg) @@ -3744,22 +3760,23 @@ (set! let-bindings (cons #`[#,var #,x] let-bindings))])) (set! arg-list (reverse arg-list)) (set! let-bindings (reverse let-bindings)) - - (syntax-property - (quasisyntax/loc stx - (let*-values ([(sym) (quasiquote (unsyntax (localize name)))] - [(receiver) (unsyntax obj)] - [(method) (find-method/who '(unsyntax form) receiver sym)]) - (let (#,@(if kw-args - (list #`[kw-arg-tmp #,(cadr kw-args)]) - (list)) - #,@let-bindings) - (unsyntax - (make-method-call-to-possibly-wrapped-object - stx kw-args/var arg-list rest-arg? - #'sym #'method #'receiver - (quasisyntax/loc stx (find-method/who '(unsyntax form) receiver sym))))))) - 'feature-profile:send-dispatch #t))) + + (class-syntax-protect + (syntax-property + (quasisyntax/loc stx + (let*-values ([(sym) (quasiquote (unsyntax (localize name)))] + [(receiver) (unsyntax obj)] + [(method) (find-method/who '(unsyntax form) receiver sym)]) + (let (#,@(if kw-args + (list #`[kw-arg-tmp #,(cadr kw-args)]) + (list)) + #,@let-bindings) + (unsyntax + (make-method-call-to-possibly-wrapped-object + stx kw-args/var arg-list rest-arg? + #'sym #'method #'receiver + (quasisyntax/loc stx (find-method/who '(unsyntax form) receiver sym))))))) + 'feature-profile:send-dispatch #t)))) (define (core-send apply? kws?) (lambda (stx) @@ -3830,18 +3847,19 @@ (define-syntax (send* stx) (syntax-case stx () [(form obj clause ...) - (quasisyntax/loc stx - (let* ([o obj]) - (unsyntax-splicing - (map - (lambda (clause-stx) - (syntax-case clause-stx () - [(meth . args) - (quasisyntax/loc stx - (send o meth . args))] - [_ (raise-syntax-error - #f "bad method call" stx clause-stx)])) - (syntax->list (syntax (clause ...)))))))])) + (class-syntax-protect + (quasisyntax/loc stx + (let* ([o obj]) + (unsyntax-splicing + (map + (lambda (clause-stx) + (syntax-case clause-stx () + [(meth . args) + (quasisyntax/loc stx + (send o meth . args))] + [_ (raise-syntax-error + #f "bad method call" stx clause-stx)])) + (syntax->list (syntax (clause ...))))))))])) ;; functional chained send (define-syntax (send+ stx) @@ -3850,10 +3868,12 @@ (pattern [name:id . args])) (syntax-parse stx [(_ obj:expr clause-0:send-clause clause:send-clause ...) - (quasisyntax/loc stx - (let ([o (send obj clause-0.name . clause-0.args)]) - (send+ o clause ...)))] - [(_ obj:expr) (syntax/loc stx obj)])) + (class-syntax-protect + (quasisyntax/loc stx + (let ([o (send obj clause-0.name . clause-0.args)]) + (send+ o clause ...))))] + [(_ obj:expr) (class-syntax-protect + (syntax/loc stx obj))])) ;; find-method/who : symbol[top-level-form/proc-name] ;; any[object] @@ -4019,17 +4039,18 @@ [flat-stx (if proper? args-stx (flatten-args args-stx))]) (with-syntax ([(gen obj) (generate-temporaries (syntax (generic object)))]) - (quasisyntax/loc stx - (let* ([obj object] - [gen generic]) - ;(check-generic gen) - (unsyntax - (make-method-call-to-possibly-wrapped-object - stx #f flat-stx (not proper?) - #'(generic-name gen) - #'((generic-applicable gen) obj) - #'obj - #'((generic-applicable gen) obj)))))))])) + (class-syntax-protect + (quasisyntax/loc stx + (let* ([obj object] + [gen generic]) + ;(check-generic gen) + (unsyntax + (make-method-call-to-possibly-wrapped-object + stx #f flat-stx (not proper?) + #'(generic-name gen) + #'((generic-applicable gen) obj) + #'obj + #'((generic-applicable gen) obj))))))))])) (define (check-generic gen) (unless (generic? gen) @@ -4050,7 +4071,8 @@ name)) (with-syntax ([name (localize name)] [make make]) - (syntax/loc stx (make class-expr `name))))] + (class-syntax-protect + (syntax/loc stx (make class-expr `name)))))] [(_ class-expr) (raise-syntax-error #f @@ -4067,7 +4089,8 @@ [(_ name obj val) (identifier? #'name) (with-syntax ([localized (localize #'name)]) - (syntax/loc stx (set-field!/proc `localized obj val)))] + (class-syntax-protect + (syntax/loc stx (set-field!/proc `localized obj val))))] [(_ name obj val) (raise-syntax-error 'set-field! "expected a field name as first argument" @@ -4121,7 +4144,8 @@ [(_ name obj) (identifier? (syntax name)) (with-syntax ([localized (localize (syntax name))]) - (syntax/loc stx (get-field/proc `localized obj)))] + (class-syntax-protect + (syntax/loc stx (get-field/proc `localized obj))))] [(_ name obj) (raise-syntax-error 'get-field "expected a field name as first argument" @@ -4175,7 +4199,8 @@ [(_ name obj) (identifier? (syntax name)) (with-syntax ([localized (localize (syntax name))]) - (syntax (field-bound?/proc `localized obj)))] + (class-syntax-protect + (syntax (field-bound?/proc `localized obj))))] [(_ name obj) (raise-syntax-error 'field-bound? "expected a field name as first argument" @@ -4223,19 +4248,20 @@ (with-syntax ([(method ...) (generate-temporaries ids)] [(method-obj ...) (generate-temporaries ids)] [(name ...) (map localize names)]) - (syntax/loc stx (let-values ([(method method-obj) - (let ([obj obj-expr]) - (values (find-method/who 'with-method obj `name) - obj))] - ...) - (letrec-syntaxes+values ([(id) (make-with-method-map - (quote-syntax set!) - (quote-syntax id) - (quote-syntax method) - (quote-syntax method-obj))] - ...) - () - body0 body1 ...)))))] + (class-syntax-protect + (syntax/loc stx (let-values ([(method method-obj) + (let ([obj obj-expr]) + (values (find-method/who 'with-method obj `name) + obj))] + ...) + (letrec-syntaxes+values ([(id) (make-with-method-map + (quote-syntax set!) + (quote-syntax id) + (quote-syntax method) + (quote-syntax method-obj))] + ...) + () + body0 body1 ...))))))] ;; Error cases: [(_ (clause ...) . body) (begin @@ -4783,16 +4809,16 @@ (λ (super%) (check-mixin-super mixin-name super% (list from-ids ...)) class-expr))]) - ;; Finally, build the complete mixin expression: - (syntax/loc stx - (let ([from-ids from] ...) - (let ([to-ids to] ...) - (check-mixin-from-interfaces (list from-ids ...)) - (check-mixin-to-interfaces (list to-ids ...)) - (check-interface-includes (list (quasiquote super-vars) ...) - (list from-ids ...)) - mixin-expr)))))))])) + (class-syntax-protect + (syntax/loc stx + (let ([from-ids from] ...) + (let ([to-ids to] ...) + (check-mixin-from-interfaces (list from-ids ...)) + (check-mixin-to-interfaces (list to-ids ...)) + (check-interface-includes (list (quasiquote super-vars) ...) + (list from-ids ...)) + mixin-expr))))))))])) (define externalizable<%> (_interface () externalize internalize)) diff -Nru racket-7.2+ppa2/collects/racket/private/c.rkt racket-7.3+ppa1/collects/racket/private/c.rkt --- racket-7.2+ppa2/collects/racket/private/c.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/private/c.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,366 @@ +;;---------------------------------------------------------------------- +;; case: based on Clinger, "Rapid Case Dispatch in Scheme" +;; [http://scheme2006.cs.uchicago.edu/07-clinger.pdf] + +(module case '#%kernel + (#%require '#%paramz '#%unsafe "small-scheme.rkt" "define.rkt" + (for-syntax '#%kernel "small-scheme.rkt" "stxcase-scheme.rkt" + "qqstx.rkt" "define.rkt" "sort.rkt")) + (#%provide case) + + + (define-syntax (case stx) + (syntax-case stx (else) + ;; Empty case + [(_ v) + (syntax-protect + (syntax/loc stx (#%expression (begin v (void)))))] + + ;; Else-only case + [(_ v [else e es ...]) + (syntax-protect + (syntax/loc stx (#%expression (begin v (let-values () e es ...)))))] + + ;; If we have a syntactically correct form without an 'else' clause, + ;; add the default 'else' and try again. + [(self v [(k ...) e1 e2 ...] ...) + (syntax-protect + (syntax/loc stx (self v [(k ...) e1 e2 ...] ... [else (void)])))] + + ;; The general case + [(_ v [(k ...) e1 e2 ...] ... [else x1 x2 ...]) + (syntax-protect + (if (< (length (syntax-e #'(k ... ...))) *sequential-threshold*) + (syntax/loc stx (let ([tmp v]) + (case/sequential tmp [(k ...) e1 e2 ...] ... [else x1 x2 ...]))) + (syntax/loc stx (let ([tmp v]) + (case/dispatch tmp [(k ...) e1 e2 ...] ... [else x1 x2 ...])))))] + + ;; Error cases + [(_ v clause ...) + (let loop ([clauses (syntax->list #'(clause ...))]) + (unless (null? clauses) + (let ([clause (car clauses)]) + (syntax-case clause () + [((_ ...) _ _ ...) + (loop (cdr clauses))] + [((_ ...) . _) + (syntax-case clause () + [(_) + (raise-syntax-error + #f + "bad syntax (missing expression after datum sequence)" + stx + clause)] + [(_ . _) + (raise-syntax-error + #f + "bad syntax (illegal use of `.' in clause)" + stx + clause)] + [_ + (raise-syntax-error + #f + "bad syntax (ill-formed clause)" + stx + clause)])] + [(bad . _) + (raise-syntax-error + #f + ;; If #'bad is an identifier, report its binding in the error message. + ;; This helps resolving the syntax error when `else' is shadowed somewhere + (if (not (symbol? (syntax-e (syntax bad)))) + "bad syntax (not a datum sequence)" + (string-append + "bad syntax (not a datum sequence)\n" + " expected: a datum sequence or the binding 'else' from racket/base\n" + " given: " + (let ([binding (identifier-binding (syntax bad))]) + (cond + [(not binding) "an unbound identifier"] + [(eq? binding 'lexical) "a locally bound identifier"] + [else + (let*-values ([(src) (car binding)] + [(mpath base) (module-path-index-split src)]) + (cond + [(not mpath) + "an identifier bound by the current module"] + [else + (format "an identifier required from the module ~a" + (resolved-module-path-name + (module-path-index-resolve src)))]))])))) + stx + (syntax bad))] + [_ + (raise-syntax-error + #f + "bad syntax (ill-formed clause)" + stx + (syntax bad))]))))] + [(_ . v) + (not (null? (syntax-e (syntax v)))) + (raise-syntax-error + #f + "bad syntax (illegal use of `.')" + stx)])) + + ;; Sequential case: + ;; Turn the expression into a sequence of if-then-else. + (define-syntax (case/sequential stx) + (syntax-case stx (else) + [(_ v [(k ...) es ...] arms ... [else xs ...]) + (syntax-protect + #'(if (case/sequential-test v (k ...)) + (let-values () es ...) + (case/sequential v arms ... [else xs ...])))] + [(_ v [(k ...) es ...] [else xs ...]) + (syntax-protect + #'(if (case/sequential-test v (k ...)) + (let-values () es ...) + (let-values () xs ...)))] + [(_ v [else xs ...]) + (syntax-protect + #'(let-values () xs ...))])) + + (define-syntax (case/sequential-test stx) + (syntax-protect + (syntax-case stx () + [(_ v ()) #'#f] + [(_ v (k)) #`(equal? v 'k)] + [(_ v (k ks ...)) #`(if (equal? v 'k) + #t + (case/sequential-test v (ks ...)))]))) + + ;; Triple-dispatch case: + ;; (1) From the type of the value to a type-specific mechanism for + ;; (2) mapping the value to the index of the consequent we need. Then, + ;; (3) from the index, perform a binary search to find the consequent code. + ;; Note: the else clause is given index 0. + (define-syntax (case/dispatch stx) + (syntax-case stx (else) + [(_ v [(k ...) es ...] ... [else xs ...]) + (syntax-protect + #`(let ([index + #,(let* ([ks (partition-constants #'((k ...) ...))] + [exp #'0] + [exp (if (null? (consts-other ks)) + exp + (dispatch-other #'v (consts-other ks) exp))] + [exp (if (null? (consts-char ks)) + exp + #`(if (char? v) + #,(dispatch-char #'v (consts-char ks)) + #,exp))] + [exp (if (null? (consts-symbol ks)) + exp + #`(if #,(test-for-symbol #'v (consts-symbol ks)) + #,(dispatch-symbol #'v (consts-symbol ks) #'0) + #,exp))] + [exp (if (null? (consts-fixnum ks)) + exp + #`(if (fixnum? v) + #,(dispatch-fixnum #'v (consts-fixnum ks)) + #,exp))]) + exp)]) + #,(index-binary-search #'index #'([xs ...] [es ...] ...))))])) + + + (begin-for-syntax + (define *sequential-threshold* 12) + (define *hash-threshold* 10) + + (define nothing (gensym)) + + (define interval-lo car) + (define interval-hi cadr) + (define interval-index caddr) + + (define (partition-constants stx) + (define h (make-hash)) + + (define (duplicate? x) + (not (eq? (hash-ref h x nothing) nothing))) + + (define (add xs x idx) + (hash-set! h x idx) + (cons (cons x idx) xs)) + + (let loop ([f '()] [s '()] [c '()] [o '()] [idx 1] [xs (syntax->list stx)]) + (cond [(null? xs) + (list (cons 'fixnum f) + (cons 'symbol s) + (cons 'char c) + (cons 'other o))] + [else (let inner ([f f] [s s] [c c] [o o] [ys (syntax->list (car xs))]) + (cond [(null? ys) (loop f s c o (add1 idx) (cdr xs))] + [else + (let ([y (syntax->datum (car ys))]) + (cond [(duplicate? y) (inner f s c o (cdr ys))] + [(fixnum? y) (inner (add f y idx) s c o (cdr ys))] + [(symbol? y) (inner f (add s y idx) c o (cdr ys))] + [(keyword? y) (inner f (add s y idx) c o (cdr ys))] + [(char? y) (inner f s (add c y idx) o (cdr ys))] + [else (inner f s c (add o y idx) (cdr ys))]))]))]))) + + (define (consts-fixnum ks) (cdr (assq 'fixnum ks))) + (define (consts-symbol ks) (cdr (assq 'symbol ks))) + (define (consts-char ks) (cdr (assq 'char ks))) + (define (consts-other ks) (cdr (assq 'other ks))) + + ;; Character dispatch is fixnum dispatch. + (define (dispatch-char tmp-stx char-alist) + #`(let ([codepoint (char->integer #,tmp-stx)]) + #,(dispatch-fixnum #'codepoint + (map (λ (x) + (cons (char->integer (car x)) + (cdr x))) + char-alist)))) + + ;; Symbol and "other" dispatch is either sequential or + ;; hash-table-based, depending on how many constants we + ;; have. Assume that `alist' does not map anything to `#f'. + (define (dispatch-hashable tmp-stx alist make-hashX else-exp) + (if (< (length alist) *hash-threshold*) + #`(case/sequential #,tmp-stx + #,@(map (λ (x) + #`[(#,(car x)) #,(cdr x)]) + alist) + [else #,else-exp]) + (let ([tbl (make-hashX alist)]) + (if (literal-expression? else-exp) + #`(hash-ref #,tbl #,tmp-stx (lambda () #,else-exp)) + #`(or (hash-ref #,tbl #,tmp-stx (lambda () #f)) + #,else-exp))))) + + (define (dispatch-symbol tmp-stx symbol-alist else-exp) + (dispatch-hashable tmp-stx symbol-alist make-immutable-hasheq else-exp)) + + (define (dispatch-other tmp-stx other-alist else-exp) + (dispatch-hashable tmp-stx other-alist make-immutable-hash else-exp)) + + (define (test-for-symbol tmp-stx alist) + (define (contains? pred) + (ormap (lambda (p) (pred (car p))) alist)) + (if (contains? symbol?) + (if (contains? keyword?) + #`(or (symbol? #,tmp-stx) (keyword? #,tmp-stx)) + #`(symbol? #,tmp-stx)) + #`(keyword? #,tmp-stx))) + + (define (literal-expression? else-exp) + (define v (syntax-e else-exp)) + (or (boolean? v) (number? v))) + + ;; Fixnum dispatch is either table lookup or binary search. + (define (dispatch-fixnum tmp-stx fixnum-alist) + (define (go intervals lo hi lo-bound hi-bound) + (define len (length intervals)) + + (cond [(or (>= lo-bound hi) + (<= hi-bound lo)) + #'0] + [(and (> len 1) + (< (- hi lo) (* len 5))) + (fixnum-table-lookup intervals lo hi lo-bound hi-bound)] + [else + (fixnum-binary-search intervals lo hi lo-bound hi-bound)])) + + (define (fixnum-table-lookup intervals lo hi lo-bound hi-bound) + (define index-lists + (map (λ (int) + (vector->list + (make-vector (- (interval-hi int) + (interval-lo int)) + (interval-index int)))) + intervals)) + + #`(let ([tbl #,(list->vector (apply append index-lists))]) + #,(bounded-expr tmp-stx lo hi lo-bound hi-bound + #`(unsafe-vector*-ref tbl (unsafe-fx- #,tmp-stx #,lo))))) + + (define (fixnum-binary-search intervals lo hi lo-bound hi-bound) + (cond [(null? (cdr intervals)) + #`#,(interval-index (car intervals))] + [else + (define-values (lo-ints hi-ints) (split-intervals intervals)) + (define-values (lo-lo lo-hi) (lo+hi lo-ints)) + (define-values (hi-lo hi-hi) (lo+hi hi-ints)) + + #`(if (unsafe-fx< #,tmp-stx #,hi-lo) + #,(go lo-ints lo-lo lo-hi lo-bound hi-lo) + #,(go hi-ints hi-lo hi-hi hi-lo hi-bound))])) + + (define (split-intervals intervals) + (define n (quotient (length intervals) 2)) + (let loop ([n n] [lo '()] [hi intervals]) + (cond [(zero? n) (values (reverse lo) hi)] + [else (loop (sub1 n) (cons (car hi) lo) (cdr hi))]))) + + (define (lo+hi intervals) + (values (interval-lo (car intervals)) + (interval-hi (car (reverse intervals))))) + + (define intervals (alist->intervals fixnum-alist)) + (define-values (lo hi) (lo+hi intervals)) + + #`(if (and (unsafe-fx>= #,tmp-stx #,lo) + (unsafe-fx< #,tmp-stx #,hi)) + #,(go intervals lo hi lo hi) + 0)) + + ;; Once we have the index of the consequent we want, perform + ;; a binary search to find it. + (define (index-binary-search index-stx leg-stx) + (define legs (list->vector (syntax->list leg-stx))) + + (define (go min max) + (cond [(= min max) + #`(let-values () #,@(vector-ref legs min))] + [(= max (add1 min)) + #`(if (unsafe-fx< #,index-stx #,max) + (let-values () #,@(vector-ref legs min)) + (let-values () #,@(vector-ref legs max)))] + [else + (let ([mid (quotient (+ min max) 2)]) + #`(if (unsafe-fx< #,index-stx #,mid) + #,(go min (sub1 mid)) + #,(go mid max)))])) + + (go 0 (sub1 (vector-length legs)))) + + (define (bounded-expr tmp-stx lo hi lo-bound hi-bound exp-stx) + (cond [(and (<= hi-bound hi) + (>= lo-bound lo)) + exp-stx] + [(<= hi-bound hi) + #`(if (unsafe-fx>= #,tmp-stx #,lo) exp-stx 0)] + [(>= lo-bound lo) + #`(if (unsafe-fx< #,tmp-stx #,hi) exp-stx 0)] + [else + #`(if (and (unsafe-fx>= #,tmp-stx #,lo) + (unsafe-fx< #,tmp-stx #,hi)) + exp-stx + 0)])) + + (define (alist->intervals alist) + (let loop ([xs (sort alist < car)] [start-idx #f] [end-idx #f] [cur-val #f] [res '()]) + (cond [(null? xs) + (if start-idx + (reverse (cons (list start-idx end-idx cur-val) res)) + '())] + [else + (let* ([x (car xs)] + [k (car x)] + [v (cdr x)]) + (cond [(not start-idx) + (loop (cdr xs) k (add1 k) v res)] + [(and (= end-idx k) (= cur-val v)) + (loop (cdr xs) start-idx (add1 end-idx) cur-val res)] + [(= end-idx k) + (let ([interval (list start-idx end-idx cur-val)]) + (loop (cdr xs) k (add1 k) v (cons interval res)))] + [else + ;; insert an interval in the gap for the default + (let ([int1 (list start-idx end-idx cur-val)] + [int2 (list end-idx k 0)]) + (loop (cdr xs) k (add1 k) v (cons int2 (cons int1 res))))]))]))))) diff -Nru racket-7.2+ppa2/collects/racket/private/define-struct.rkt racket-7.3+ppa1/collects/racket/private/define-struct.rkt --- racket-7.2+ppa2/collects/racket/private/define-struct.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/private/define-struct.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -515,8 +515,10 @@ (if (struct-type? the-super) the-super (check-struct-type 'fm the-super)))))] - [prune (lambda (stx) (identifier-prune-lexical-context stx - (list (syntax-e stx) '#%top)))] + [prune (lambda (stx) + (syntax-protect + (identifier-prune-lexical-context stx + (list (syntax-e stx) '#%top))))] [reflect-name-expr (if reflect-name-expr (syntax-case reflect-name-expr (quote) [(quote id) @@ -739,6 +741,8 @@ (lambda () (cond [(and info-name (not name-only?)) + (when omit-define-syntaxes? + (raise-syntax-error #f "#:extra-name cannot be combined with #:omit-define-syntaxes" stx)) ; reuse existing value (list #`(define-syntaxes (#,info-name) (syntax-local-value #'#,id)))] [else null]))]) diff -Nru racket-7.2+ppa2/collects/racket/private/for.rkt racket-7.3+ppa1/collects/racket/private/for.rkt --- racket-7.2+ppa2/collects/racket/private/for.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/private/for.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1442,20 +1442,23 @@ (cond [(null? l) ;; No #:break form - #'(inner-recur fold-vars (let-values () expr ...) (if final?-id break-k next-k))] + (syntax-protect + #'(inner-recur fold-vars (let-values () expr ...) (if final?-id break-k next-k)))] [(eq? '#:break (syntax-e (car l))) ;; Found a #:break form - #`(let-values () - #,@(reverse pre-accum) - (if #,(cadr l) - break-k - (push-under-break inner-recur fold-vars #,(cddr l) next-k break-k final?-id)))] + (syntax-protect + #`(let-values () + #,@(reverse pre-accum) + (if #,(cadr l) + break-k + (push-under-break inner-recur fold-vars #,(cddr l) next-k break-k final?-id))))] [(eq? '#:final (syntax-e (car l))) ;; Found a #:final form - #`(let-values () - #,@(reverse pre-accum) - (let ([final? (or #,(cadr l) final?-id)]) - (push-under-break inner-recur fold-vars #,(cddr l) next-k break-k final?)))] + (syntax-protect + #`(let-values () + #,@(reverse pre-accum) + (let ([final? (or #,(cadr l) final?-id)]) + (push-under-break inner-recur fold-vars #,(cddr l) next-k break-k final?))))] [else (loop (cdr l) (cons (car l) pre-accum))]))])) (define-syntax (for/foldX/derived stx) @@ -1465,15 +1468,18 @@ expr1 expr ...) (if (syntax-e #'inner-recur) ;; General, non-nested-loop approach: - #`(let ([fold-var fold-init] ...) - (push-under-break inner-recur (fold-var ...) [expr1 expr ...] next-k break-k final?-id)) + (syntax-protect + #`(let ([fold-var fold-init] ...) + (push-under-break inner-recur (fold-var ...) [expr1 expr ...] next-k break-k final?-id))) ;; Nested-loop approach (which is slightly faster when it works): - #`(let ([fold-var fold-init] ...) - (let-values ([(fold-var ...) (let () expr1 expr ...)]) - (values fold-var ...))))] + (syntax-protect + #`(let ([fold-var fold-init] ...) + (let-values ([(fold-var ...) (let () expr1 expr ...)]) + (values fold-var ...)))))] ;; Switch-to-emit case (no more clauses to generate): [(_ [orig-stx inner-recur nested? #f binds] fold-bind next-k break-k final?-id () . body) - #`(for/foldX/derived [orig-stx inner-recur nested? #t binds] fold-bind next-k break-k final?-id () . body)] + (syntax-protect + #`(for/foldX/derived [orig-stx inner-recur nested? #t binds] fold-bind next-k break-k final?-id () . body))] ;; Emit case: [(_ [orig-stx inner-recur nested? #t binds] ([fold-var fold-init] ...) next-k break-k final?-id rest expr1 . body) (with-syntax ([(([outer-binding ...] @@ -1484,37 +1490,38 @@ pre-guard post-guard [loop-arg ...]) ...) (reverse (syntax->list #'binds))]) - (quasisyntax/loc #'orig-stx - (let-values (outer-binding ... ...) - outer-check ... - #,(quasisyntax/loc #'orig-stx - (let for-loop ([fold-var fold-init] ... - loop-binding ... ...) - (if (and pos-guard ...) - (let-values (inner-binding ... ...) - (if (and pre-guard ...) - #,(if (syntax-e #'inner-recur) - ;; The general non-nested-loop approach: - #'(let ([post-guard-var (lambda (fold-var ...) (and post-guard ...))]) - (for/foldX/derived [orig-stx inner-recur nested? #f ()] - ([fold-var fold-var] ...) - (if (post-guard-var fold-var ...) - (for-loop fold-var ... loop-arg ... ...) - next-k) - break-k final?-id - rest expr1 . body)) - ;; The specialized nested-loop approach, which is - ;; slightly faster when it works: - #'(let-values ([(fold-var ...) - (for/foldX/derived [orig-stx inner-recur nested? #f ()] - ([fold-var fold-var] ...) - next-k break-k final?-id - rest expr1 . body)]) - (if (and post-guard ... (not final?-id)) - (for-loop fold-var ... loop-arg ... ...) - next-k))) - next-k)) - next-k))))))] + (syntax-protect + (quasisyntax/loc #'orig-stx + (let-values (outer-binding ... ...) + outer-check ... + #,(quasisyntax/loc #'orig-stx + (let for-loop ([fold-var fold-init] ... + loop-binding ... ...) + (if (and pos-guard ...) + (let-values (inner-binding ... ...) + (if (and pre-guard ...) + #,(if (syntax-e #'inner-recur) + ;; The general non-nested-loop approach: + #'(let ([post-guard-var (lambda (fold-var ...) (and post-guard ...))]) + (for/foldX/derived [orig-stx inner-recur nested? #f ()] + ([fold-var fold-var] ...) + (if (post-guard-var fold-var ...) + (for-loop fold-var ... loop-arg ... ...) + next-k) + break-k final?-id + rest expr1 . body)) + ;; The specialized nested-loop approach, which is + ;; slightly faster when it works: + #'(let-values ([(fold-var ...) + (for/foldX/derived [orig-stx inner-recur nested? #f ()] + ([fold-var fold-var] ...) + next-k break-k final?-id + rest expr1 . body)]) + (if (and post-guard ... (not final?-id)) + (for-loop fold-var ... loop-arg ... ...) + next-k))) + next-k)) + next-k)))))))] ;; Bad body cases: [(_ [orig-stx . _] fold-bind next-k break-k final?-id ()) (raise-syntax-error @@ -1524,43 +1531,49 @@ #f "bad syntax (illegal use of `.') after sequence bindings" #'orig-stx)] ;; Guard case, no pending emits: [(_ [orig-stx inner-recur nested? #f ()] ([fold-var fold-init] ...) next-k break-k final?-id (#:when expr . rest) . body) - #'(let ([fold-var fold-init] ...) - (if expr - (for/foldX/derived [orig-stx inner-recur nested? #f ()] - ([fold-var fold-var] ...) next-k break-k final?-id rest . body) - next-k))] + (syntax-protect + #'(let ([fold-var fold-init] ...) + (if expr + (for/foldX/derived [orig-stx inner-recur nested? #f ()] + ([fold-var fold-var] ...) next-k break-k final?-id rest . body) + next-k)))] ;; Negative guard case, no pending emits: [(_ [orig-stx inner-recur nested? #f ()] ([fold-var fold-init] ...) next-k break-k final?-id (#:unless expr . rest) . body) - #'(let ([fold-var fold-init] ...) - (if expr - (if final?-id break-k next-k) - (for/foldX/derived [orig-stx inner-recur nested? #f ()] - ([fold-var fold-var] ...) next-k break-k final?-id rest . body)))] + (syntax-protect + #'(let ([fold-var fold-init] ...) + (if expr + (if final?-id break-k next-k) + (for/foldX/derived [orig-stx inner-recur nested? #f ()] + ([fold-var fold-var] ...) next-k break-k final?-id rest . body))))] ;; Break case, no pending emits: [(_ [orig-stx inner-recur nested? #f ()] ([fold-var fold-init] ...) next-k break-k final?-id (#:break expr . rest) . body) - #'(let ([fold-var fold-init] ...) - (if expr - break-k - (for/foldX/derived [orig-stx inner-recur nested? #f ()] - ([fold-var fold-var] ...) next-k break-k final?-id rest . body)))] + (syntax-protect + #'(let ([fold-var fold-init] ...) + (if expr + break-k + (for/foldX/derived [orig-stx inner-recur nested? #f ()] + ([fold-var fold-var] ...) next-k break-k final?-id rest . body))))] ;; Final case, no pending emits: [(_ [orig-stx inner-recur nested? #f ()] ([fold-var fold-init] ...) next-k break-k final?-id (#:final expr . rest) . body) - #'(let ([fold-var fold-init] ...) - (let ([final? (or expr final?-id)]) - (for/foldX/derived [orig-stx inner-recur nested? #f ()] - ([fold-var fold-var] ...) next-k break-k final? rest . body)))] + (syntax-protect + #'(let ([fold-var fold-init] ...) + (let ([final? (or expr final?-id)]) + (for/foldX/derived [orig-stx inner-recur nested? #f ()] + ([fold-var fold-var] ...) next-k break-k final? rest . body))))] ;; Keyword case, pending emits need to be flushed first [(frm [orig-stx inner-recur nested? #f binds] ([fold-var fold-init] ...) next-k break-k final?-id (kw expr . rest) . body) (or (eq? (syntax-e #'kw) '#:when) (eq? (syntax-e #'kw) '#:unless) (eq? (syntax-e #'kw) '#:break) (eq? (syntax-e #'kw) '#:final)) - #'(frm [orig-stx inner-recur nested? #t binds] ([fold-var fold-init] ...) next-k break-k final?-id (kw expr . rest) . body)] + (syntax-protect + #'(frm [orig-stx inner-recur nested? #t binds] ([fold-var fold-init] ...) next-k break-k final?-id (kw expr . rest) . body))] ;; Convert single-value form to multi-value form: [(_ [orig-stx inner-recur nested? #f binds] fold-bind next-k break-k final?-id ([id rhs] . rest) . body) (identifier? #'id) - #'(for/foldX/derived [orig-stx inner-recur nested? #f binds] fold-bind next-k break-k final?-id - ([(id) rhs] . rest) . body)] + (syntax-protect + #'(for/foldX/derived [orig-stx inner-recur nested? #f binds] fold-bind next-k break-k final?-id + ([(id) rhs] . rest) . body))] ;; If we get here in single-value mode, then it's a bad clause: [(_ [orig-stx inner-recur #f #f nested? #f binds] fold-bind next-k break-k final?-id (clause . rest) . body) (raise-syntax-error @@ -1587,28 +1600,32 @@ ;; non-nested loop approach to implement them: (ormap (lambda (s) (or (eq? '#:break (syntax-e s)) (eq? '#:final (syntax-e s)))) (syntax->list #'(clause ... expr ...))) - #'(for/foldX/derived [orig-stx inner-recur/fold nested? #f ()] fold-bind done-k done-k #f (clause ...) expr ...)] + (syntax-protect + #'(for/foldX/derived [orig-stx inner-recur/fold nested? #f ()] fold-bind done-k done-k #f (clause ...) expr ...))] [(_ [orig-stx nested?] fold-bind done-k . rest) ;; Otherwise, allow compilation as nested loops, which can be slightly faster: - #'(for/foldX/derived [orig-stx #f nested? #f ()] fold-bind done-k done-k #f . rest)])) + (syntax-protect + #'(for/foldX/derived [orig-stx #f nested? #f ()] fold-bind done-k done-k #f . rest))])) (define-syntax (for/fold/derived stx) (syntax-case stx () [(_ orig-stx ([fold-var finid-init] ... #:result result-expr) . rest) (check-identifier-bindings #'orig-stx #'(fold-var ...) "accumulator" #t) - (syntax/loc #'orig-stx - (let-values ([(fold-var ...) (for/foldX/derived/final [orig-stx #f] - ([fold-var finid-init] ...) - (values* fold-var ...) - . rest)]) - result-expr))] + (syntax-protect + (syntax/loc #'orig-stx + (let-values ([(fold-var ...) (for/foldX/derived/final [orig-stx #f] + ([fold-var finid-init] ...) + (values* fold-var ...) + . rest)]) + result-expr)))] [(_ orig-stx ([fold-var finid-init] ...) . rest) (check-identifier-bindings #'orig-stx #'(fold-var ...) "accumulator" #t) - (syntax/loc #'orig-stx - (for/foldX/derived/final [orig-stx #f] - ([fold-var finid-init] ...) - (values* fold-var ...) - . rest))] + (syntax-protect + (syntax/loc #'orig-stx + (for/foldX/derived/final [orig-stx #f] + ([fold-var finid-init] ...) + (values* fold-var ...) + . rest)))] [(_ orig-stx (bindings ...) . rst) (raise-syntax-error #f "invalid accumulator binding clause(s)" #'orig-stx #'(bindings ...))] [(_ orig-stx . rst) @@ -1618,19 +1635,21 @@ (syntax-case stx () [(_ orig-stx ([fold-var finid-init] ... #:result result-expr) . rest) (check-identifier-bindings #'orig-stx #'(fold-var ...) "accumulator" #t) - (syntax/loc #'orig-stx - (let-values ([(fold-var ...) (for/foldX/derived/final [orig-stx #t] - ([fold-var finid-init] ...) - (values* fold-var ...) - . rest)]) - result-expr))] + (syntax-protect + (syntax/loc #'orig-stx + (let-values ([(fold-var ...) (for/foldX/derived/final [orig-stx #t] + ([fold-var finid-init] ...) + (values* fold-var ...) + . rest)]) + result-expr)))] [(_ orig-stx ([fold-var finid-init] ...) . rest) (check-identifier-bindings #'orig-stx #'(fold-var ...) "accumulator" #t) - (syntax/loc #'orig-stx - (for/foldX/derived/final [orig-stx #t] - ([fold-var finid-init] ...) - (values* fold-var ...) - . rest))] + (syntax-protect + (syntax/loc #'orig-stx + (for/foldX/derived/final [orig-stx #t] + ([fold-var finid-init] ...) + (values* fold-var ...) + . rest)))] [(_ orig-stx (bindings ...) . rst) (raise-syntax-error #f "invalid accumulator binding clause(s)" #'orig-stx #'(bindings ...))] [(_ orig-stx . rst) @@ -1721,10 +1740,12 @@ (define-syntax (for/fold stx) (syntax-case stx () - [(_ . rest) (quasisyntax/loc stx (for/fold/derived #,stx . rest))])) + [(_ . rest) (syntax-protect + (quasisyntax/loc stx (for/fold/derived #,stx . rest)))])) (define-syntax (for*/fold stx) (syntax-case stx () - [(_ . rest) (quasisyntax/loc stx (for*/fold/derived #,stx . rest))])) + [(_ . rest) (syntax-protect + (quasisyntax/loc stx (for*/fold/derived #,stx . rest)))])) (define-for-variants (for for*) () @@ -1755,20 +1776,21 @@ (with-syntax ([orig-stx orig-stx] [for_/fold/derived for_/fold/derived-stx] [((middle-body ...) (last-body ...)) (split-for-body stx #'(body ...))]) - (syntax/loc stx - (let-values ([(vec i) - (for_/fold/derived - orig-stx - ([vec (make-vector 16)] - [i 0]) - (for-clause ...) - middle-body ... - (let ([new-vec (if (eq? i (unsafe-vector*-length vec)) - (grow-vector vec) - vec)]) - (unsafe-vector*-set! new-vec i (let () last-body ...)) - (values new-vec (unsafe-fx+ i 1))))]) - (shrink-vector vec i))))] + (syntax-protect + (syntax/loc stx + (let-values ([(vec i) + (for_/fold/derived + orig-stx + ([vec (make-vector 16)] + [i 0]) + (for-clause ...) + middle-body ... + (let ([new-vec (if (eq? i (unsafe-vector*-length vec)) + (grow-vector vec) + vec)]) + (unsafe-vector*-set! new-vec i (let () last-body ...)) + (values new-vec (unsafe-fx+ i 1))))]) + (shrink-vector vec i)))))] [(_ #:length length-expr #:fill fill-expr (for-clause ...) body ...) (with-syntax ([orig-stx orig-stx] [(limited-for-clause ...) @@ -1801,20 +1823,21 @@ [((middle-body ...) (last-body ...)) (split-for-body stx #'(body ...))] [for_/vector for_/vector-stx] [for_/fold/derived for_/fold/derived-stx]) - (syntax/loc stx - (let ([len length-expr]) - (unless (exact-nonnegative-integer? len) - (raise-argument-error 'for_/vector "exact-nonnegative-integer?" len)) - (let ([v (make-vector len fill-expr)]) - (unless (zero? len) - (for_/fold/derived - orig-stx - ([i 0]) - (limited-for-clause ...) - middle-body ... - (unsafe-vector*-set! v i (let () last-body ...)) - (unsafe-fx+ 1 i))) - v))))] + (syntax-protect + (syntax/loc stx + (let ([len length-expr]) + (unless (exact-nonnegative-integer? len) + (raise-argument-error 'for_/vector "exact-nonnegative-integer?" len)) + (let ([v (make-vector len fill-expr)]) + (unless (zero? len) + (for_/fold/derived + orig-stx + ([i 0]) + (limited-for-clause ...) + middle-body ... + (unsafe-vector*-set! v i (let () last-body ...)) + (unsafe-fx+ 1 i))) + v)))))] [(_ #:length length-expr (for-clause ...) body ...) (for_/vector #'(fv #:length length-expr #:fill 0 (for-clause ...) body ...) orig-stx for_/vector-stx for_/fold/derived-stx wrap-all?)])) @@ -1849,12 +1872,14 @@ (values* (alt-reverse id) ...))))) (syntax-case stx () [(_ (id ... #:result result-expr) bindings expr1 expr ...) - #`(let-values ([(id ...) - #,(do-without-result-clause - #'(_ (id ...) bindings expr1 expr ...))]) - result-expr)] + (syntax-protect + #`(let-values ([(id ...) + #,(do-without-result-clause + #'(_ (id ...) bindings expr1 expr ...))]) + result-expr))] [(_ (id ...) bindings expr1 expr ...) - (do-without-result-clause stx)])) + (syntax-protect + (do-without-result-clause stx))])) (define-syntax (for/lists stx) (do-for/lists #'for/fold/derived stx)) (define-syntax (for*/lists stx) (do-for/lists #'for*/fold/derived stx)) diff -Nru racket-7.2+ppa2/collects/racket/private/promise.rkt racket-7.3+ppa1/collects/racket/private/promise.rkt --- racket-7.2+ppa2/collects/racket/private/promise.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/private/promise.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -7,7 +7,7 @@ '#%unsafe) (#%provide force promise? promise-forced? promise-running? ;; provided to create extensions - (struct promise ()) pref pset! prop:force reify-result + (struct promise ()) (protect pref pset!) prop:force reify-result promise-forcer promise-printer (struct running ()) (struct reraise ()) @@ -249,7 +249,7 @@ ;; X = (force (lazy X)) = (force (lazy (lazy X))) = (force (lazy^n X)) (#%provide (rename lazy* lazy)) (define lazy make-composable-promise) -(define-syntax (lazy* stx) (make-delayer stx #'lazy '())) +(define-syntax (lazy* stx) (syntax-protect (make-delayer stx #'lazy '()))) ;; Creates a (generic) promise that does not compose ;; X = (force (delay X)) = (force (lazy (delay X))) @@ -261,7 +261,7 @@ ;; but provided for regular delay/force uses.) (#%provide (rename delay* delay)) (define delay make-promise) -(define-syntax (delay* stx) (make-delayer stx #'delay '())) +(define-syntax (delay* stx) (syntax-protect (make-delayer stx #'delay '()))) ;; For simplicity and efficiency this code uses thunks in promise values for ;; exceptions: this way, we don't need to tag exception values in some special diff -Nru racket-7.2+ppa2/collects/racket/private/set-types.rkt racket-7.3+ppa1/collects/racket/private/set-types.rkt --- racket-7.2+ppa2/collects/racket/private/set-types.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/private/set-types.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -521,8 +521,9 @@ (when (null? args) (raise-arguments-error who - "when inject-proc, add-proc, shrink-proc, and extract-proc are #f," - " at least one property must be supplied"))) + (string-append + "when inject-proc, add-proc, shrink-proc, and extract-proc are #f," + " at least one property must be supplied")))) (values clear-proc (or equal-key-proc (λ (s e) e)) args)) diff -Nru racket-7.2+ppa2/collects/racket/private/truncate-path.rkt racket-7.3+ppa1/collects/racket/private/truncate-path.rkt --- racket-7.2+ppa2/collects/racket/private/truncate-path.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/private/truncate-path.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1,30 +1,37 @@ #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 +;; Drop information from the path-for-some-system `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) + [(path-for-some-system? base1) (define-values (base2 name2 dir?) (split-path base1)) (cond [(not base2) ;; Path at a root - (path->string p)] + (path-for-some-system->string p)] [(symbol? name2) ;; "." or ".." before a name (string-append ".../" (path-elem->string name1))] [else - (string-append ".../" (path->string name2) "/" (path-elem->string name1))])] + (string-append ".../" (path-for-some-system->string name2) "/" (path-elem->string name1))])] [(eq? base1 'relative) (path-elem->string name1)] [else ;; Path is a root, ".", or ".." - (path->string p)])) + (path-for-some-system->string p)])) (define (path-elem->string p) (cond [(eq? p 'same) "."] [(eq? p 'up) ".."] - [else (path->string p)])) + [else (path-for-some-system->string p)])) + +(define (path-for-some-system->string p) + (cond + [(path? p) (path->string p)] + [else + ;; There's no right answer here, but UTF-8 likely works out + (bytes->string/utf-8 (path->bytes p) #\uFFFD)])) diff -Nru racket-7.2+ppa2/collects/racket/private/unit-utils.rkt racket-7.3+ppa1/collects/racket/private/unit-utils.rkt --- racket-7.2+ppa2/collects/racket/private/unit-utils.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/private/unit-utils.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -51,10 +51,12 @@ member-table i)))] [(x . y) - (quote-syntax - (#,(add-ctc i (bound-identifier-mapping-get - member-table - i)) . y))])))]))) + (quasisyntax + (#,(quote-syntax + #,(add-ctc i (bound-identifier-mapping-get + member-table + i))) + . y))])))]))) (define-syntax (unit-export stx) (syntax-case stx () diff -Nru racket-7.2+ppa2/collects/racket/private/vector-wraps.rkt racket-7.3+ppa1/collects/racket/private/vector-wraps.rkt --- racket-7.2+ppa2/collects/racket/private/vector-wraps.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/private/vector-wraps.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -62,23 +62,24 @@ (with-syntax ([orig-stx orig-stx] [for_/fold/derived for_/fold/derived-stx] [((middle-body ...) (last-body ...)) (split-for-body stx #'(body ...))]) - (syntax/loc stx - (let-values ([(vec i) - (for_/fold/derived - orig-stx - ([vec (make-fXvector 16)] - [i 0]) - (for-clause ...) - middle-body ... - (let ([new-vec (if (eq? i (unsafe-fXvector-length vec)) - (grow-fXvector vec) - vec)]) - (let ([elem (let () last-body ...)]) - (if (fX? elem) - (unsafe-fXvector-set! new-vec i elem) - (not-an-fX 'for*/fXvector elem))) - (values new-vec (unsafe-fx+ i 1))))]) - (shrink-fXvector vec i))))] + (syntax-protect + (syntax/loc stx + (let-values ([(vec i) + (for_/fold/derived + orig-stx + ([vec (make-fXvector 16)] + [i 0]) + (for-clause ...) + middle-body ... + (let ([new-vec (if (eq? i (unsafe-fXvector-length vec)) + (grow-fXvector vec) + vec)]) + (let ([elem (let () last-body ...)]) + (if (fX? elem) + (unsafe-fXvector-set! new-vec i elem) + (not-an-fX 'for*/fXvector elem))) + (values new-vec (unsafe-fx+ i 1))))]) + (shrink-fXvector vec i)))))] [(for*/fXvector #:length length-expr #:fill fill-expr (for-clause ...) body ...) (with-syntax ([orig-stx orig-stx] [(limited-for-clause ...) @@ -111,24 +112,25 @@ [((middle-body ...) (last-body ...)) (split-for-body stx #'(body ...))] [for_/fXvector for_/fXvector-stx] [for_/fold/derived for_/fold/derived-stx]) - (syntax/loc stx - (let ([len length-expr]) - (unless (exact-nonnegative-integer? len) - (raise-argument-error 'for_/fXvector "exact-nonnegative-integer?" len)) - (let ([fill fill-expr]) - (let ([v (make-fXvector len fill)]) - (unless (zero? len) - (for_/fold/derived - orig-stx - ([i 0]) - (limited-for-clause ...) - middle-body ... - (let ([elem (let () last-body ...)]) - (if (fX? elem) - (unsafe-fXvector-set! v i elem) - (not-an-fX 'for*/vector elem))) - (unsafe-fx+ 1 i))) - v)))))] + (syntax-protect + (syntax/loc stx + (let ([len length-expr]) + (unless (exact-nonnegative-integer? len) + (raise-argument-error 'for_/fXvector "exact-nonnegative-integer?" len)) + (let ([fill fill-expr]) + (let ([v (make-fXvector len fill)]) + (unless (zero? len) + (for_/fold/derived + orig-stx + ([i 0]) + (limited-for-clause ...) + middle-body ... + (let ([elem (let () last-body ...)]) + (if (fX? elem) + (unsafe-fXvector-set! v i elem) + (not-an-fX 'for*/vector elem))) + (unsafe-fx+ 1 i))) + v))))))] [(_ #:length length-expr (for-clause ...) body ...) (for_/fXvector #'(fv #:length length-expr #:fill fXzero (for-clause ...) body ...) orig-stx for_/fXvector-stx for_/fold/derived-stx wrap-all?)])) diff -Nru racket-7.2+ppa2/collects/racket/private/with-stx.rkt racket-7.3+ppa1/collects/racket/private/with-stx.rkt --- racket-7.2+ppa2/collects/racket/private/with-stx.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/private/with-stx.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -25,7 +25,7 @@ (lambda (x s-exp?) (syntax-case x () ((_ () e1 e2 ...) - (syntax/loc x (begin e1 e2 ...))) + (syntax/loc x (let () e1 e2 ...))) ((_ ((out in) ...) e1 e2 ...) (let ([ins (syntax->list (syntax (in ...)))]) ;; Check for duplicates or other syntax errors: diff -Nru racket-7.2+ppa2/collects/racket/syntax.rkt racket-7.3+ppa1/collects/racket/syntax.rkt --- racket-7.2+ppa2/collects/racket/syntax.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/syntax.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -87,15 +87,15 @@ (begin (record-disappeared-uses (list id)) value)))) -(define (record-disappeared-uses ids) +(define (record-disappeared-uses ids [intro? (syntax-transforming?)]) (cond - [(identifier? ids) (record-disappeared-uses (list ids))] + [(identifier? ids) (record-disappeared-uses (list ids) intro?)] [(and (list? ids) (andmap identifier? ids)) (let ([uses (current-recorded-disappeared-uses)]) (when uses (current-recorded-disappeared-uses (append - (if (syntax-transforming?) + (if intro? (map syntax-local-introduce ids) ids) uses))))] @@ -205,6 +205,8 @@ (define-syntax (with-syntax* stx) (syntax-case stx () - [(_ (cl) body ...) #'(with-syntax (cl) body ...)] + [(_ () body ...) (syntax/loc stx (let () body ...))] + [(_ (cl) body ...) (syntax/loc stx (with-syntax (cl) body ...))] [(_ (cl cls ...) body ...) - #'(with-syntax (cl) (with-syntax* (cls ...) body ...))])) + (with-syntax ([with-syntax/rest (syntax/loc stx (with-syntax* (cls ...) body ...))]) + (syntax/loc stx (with-syntax (cl) with-syntax/rest)))])) diff -Nru racket-7.2+ppa2/collects/racket/unit.rkt racket-7.3+ppa1/collects/racket/unit.rkt --- racket-7.2+ppa2/collects/racket/unit.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/racket/unit.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -17,8 +17,7 @@ "private/unit-compiletime.rkt" "private/unit-syntax.rkt")) -(require racket/block - racket/unsafe/undefined +(require racket/unsafe/undefined racket/contract/base racket/contract/region racket/stxparam @@ -51,17 +50,19 @@ (begin (check-id #'name) (check-id #'arg) - #'(define-syntax name - (make-set!-transformer - (make-signature-form (λ (arg ignored) . val)))))) + (syntax-protect + #'(define-syntax name + (make-set!-transformer + (make-signature-form (λ (arg ignored) . val))))))) ((_ (name arg intro-arg) . val) (begin (check-id #'name) (check-id #'arg) (check-id #'intro-arg) - #'(define-syntax name - (make-set!-transformer - (make-signature-form (λ (arg intro-arg) . val)))))) + (syntax-protect + #'(define-syntax name + (make-set!-transformer + (make-signature-form (λ (arg intro-arg) . val))))))) ((_ . l) (let ((l (checked-syntax->list stx))) (unless (>= 3 (length l)) @@ -600,7 +601,7 @@ #'(((int-sid ...) sbody) ...) #'(((int-vid ...) vbody) ...))))) -;; build-post-val-defs : sig -> (list syntax-object) +;; build-post-val-defs+ctcs : sig -> (list/c stx-list? (listof syntax?)) (define-for-syntax (build-post-val-defs+ctcs sig) (define introduced-sig (map-sig (lambda (x) x) (make-syntax-introducer) @@ -765,19 +766,15 @@ (x (identifier? #'x) (loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs post-val-defs (cons #f ctcs))) - ((x (y z) ...) - (and (identifier? #'x) - (free-identifier=? #'x #'contracted) - (andmap identifier? (syntax->list #'(y ...)))) + ((contracted (y z) ...) + (andmap identifier? (syntax->list #'(y ...))) (loop (cdr sig-exprs) - (append (syntax->list #'(y ...)) bindings) + (append (reverse (syntax->list #'(y ...))) bindings) val-defs stx-defs post-val-defs - (append (syntax->list #'(z ...)) ctcs))) - ((x . z) - (and (identifier? #'x) - (free-identifier=? #'x #'contracted)) + (append (reverse (syntax->list #'(z ...))) ctcs))) + ((contracted . z) (raise-syntax-error 'define-signature "expected a list of [id contract] pairs after the contracted keyword" @@ -981,7 +978,8 @@ [(icount ...) (map (lambda (import) (length (car import))) import-sigs)]) - (values + (values + (syntax-protect (intro (quasisyntax/loc (error-syntax) (make-unit @@ -1033,7 +1031,7 @@ (unit-export ((export-key ...) (vector-immutable (λ () (check-not-unsafe-undefined (unbox eloc) 'int-evar)) ...)) - ...)))))))) + ...))))))))) import-tagged-sigids export-tagged-sigids dep-tagged-sigids)))))) @@ -1099,6 +1097,14 @@ (list #'(define-values (id ...) rhs))))] [else (list defn-or-expr)]))) defns&exprs)))] + [ends-in-defn? + (syntax-case expanded-body () + [(_ ... (x . _)) + (and (identifier? #'x) + (member #'x + (list #'define-values #'define-syntaxes #'define-syntax) + free-identifier=?))] + [_ #f])] ;; Get all the defined names, sorting out variable definitions ;; from syntax definitions. [defined-names-table @@ -1157,51 +1163,75 @@ "definition for imported identifier" (var-info-id defid))))) (syntax->list (localify #'ivars def-ctx))) - - (let ([marker (lambda (id) ((make-syntax-introducer) (datum->syntax #f (syntax-e id))))]) - (with-syntax ([(defn-or-expr ...) - (apply append - (map (λ (defn-or-expr) - (syntax-case defn-or-expr (define-values) - [(define-values (id ...) body) - (let* ([ids (syntax->list #'(id ...))] - [tmps (map marker ids)] - [do-one - (λ (id tmp) - (let ([var-info (bound-identifier-mapping-get - defined-names-table - id)]) - (cond - [(var-info-exported? var-info) - => - (λ (export-loc) - (let ([ctc (var-info-ctc var-info)]) - (list (if ctc - (quasisyntax/loc defn-or-expr - (begin - (contract #,ctc #,tmp - (current-contract-region) - 'cant-happen - (quote #,id) - (quote-srcloc #,id)) - (set-box! #,export-loc - (cons #,tmp (current-contract-region))))) - (quasisyntax/loc defn-or-expr - (set-box! #,export-loc #,tmp))) - (quasisyntax/loc defn-or-expr - (define-syntax #,id - (make-id-mapper (quote-syntax #,tmp)))))))] - [else (list (quasisyntax/loc defn-or-expr - (define-syntax #,id - (make-rename-transformer (quote-syntax #,tmp)))))])))]) - (cons (quasisyntax/loc defn-or-expr - (define-values #,tmps body)) - (apply append (map do-one ids tmps))))] - [else (list defn-or-expr)])) - expanded-body))]) - (internal-definition-context-track - def-ctx - #'(block defn-or-expr ...))))))))) + + ;; Handles redirection of exported definitions and collects + ;; positive-blaming `contract` expressions + (define (process-defn-or-expr defn-or-expr) + (syntax-case defn-or-expr (define-values) + [(define-values (id ...) body) + (let* ([ids (syntax->list #'(id ...))] + [tmps (generate-temporaries ids)] + [do-one + (λ (id tmp) + (let ([var-info (bound-identifier-mapping-get + defined-names-table + id)]) + (cond + [(var-info-exported? var-info) + => + (λ (export-loc) + (let ([ctc (var-info-ctc var-info)]) + (values + #`(begin + #,(quasisyntax/loc defn-or-expr + (set-box! #,export-loc + #,(if ctc + #`(cons #,tmp (current-contract-region)) + tmp))) + #,(quasisyntax/loc defn-or-expr + (define-syntax #,id + (make-id-mapper (quote-syntax #,tmp))))) + (and ctc + #`(contract #,ctc #,tmp + (current-contract-region) + 'cant-happen + (quote #,id) + (quote-srcloc #,id))))))] + [else (values (quasisyntax/loc defn-or-expr + (define-syntax #,id + (make-rename-transformer (quote-syntax #,tmp)))) + #f)])))]) + (define-values (defns-and-exprs ctc-exprs) + (for/lists [defns-and-exprs ctc-exprs] + ([id (in-list ids)] + [tmp (in-list tmps)]) + (do-one id tmp))) + (list (cons (quasisyntax/loc defn-or-expr + (define-values #,tmps + #,(if (and (pair? ids) (null? (cdr ids))) + (syntax-property #'body 'inferred-name (car ids)) + #'body))) + defns-and-exprs) + (filter values ctc-exprs)))] + [else (list (list defn-or-expr) '())])) + + (internal-definition-context-track + def-ctx + (if (null? expanded-body) + #'(void) + (with-syntax ([([(defn-or-expr ...) (ctc-expr ...)] ...) + (map process-defn-or-expr expanded-body)]) + (if ends-in-defn? + #'(let () + defn-or-expr ... ... + ctc-expr ... ... + (void)) + (with-syntax ([(defn-or-expr ... last-defn-or-expr) #'(defn-or-expr ... ...)]) + #'(let () + defn-or-expr ... + (begin0 + last-defn-or-expr + ctc-expr ... ...)))))))))))) (define-for-syntax (redirect-imports/exports import?) (lambda (table-stx @@ -1358,7 +1388,8 @@ orig-export-tagged-infos)] [name (syntax-local-infer-name (error-syntax))] [form (syntax-e (stx-car (error-syntax)))]) - (values + (values + (syntax-protect (quasisyntax/loc (error-syntax) (let ([unit-tmp unit-exp]) (check-unit unit-tmp 'form) @@ -1390,7 +1421,7 @@ orig-export-tagged-infos orig-export-sigs export-tagged-infos - export-sigs)))))))) + export-sigs))))))))) import-tagged-sigids export-tagged-sigids dep-tagged-sigids))))))) @@ -1649,6 +1680,7 @@ ;; created via compound-unit/infer. Only the `inferred` dependencies ;; will appear in this syntax property, when no inference occurs the property ;; will contain an empty list. + (syntax-protect (syntax-property (quasisyntax/loc (error-syntax) (let ([deps '()] @@ -1676,7 +1708,7 @@ 'unit:inferred-init-depends (build-init-depend-property static-dep-info - (map syntax-e (syntax->list #'((import-tag . import-sigid) ...))))) + (map syntax-e (syntax->list #'((import-tag . import-sigid) ...)))))) (map syntax-e (syntax->list #'((import-tag . import-sigid) ...))) (map syntax-e (syntax->list #'((export-tag . export-sigid) ...))) static-dep-info)))))) @@ -1816,9 +1848,10 @@ (with-syntax ((((int-id . ext-id) ...) int+ext-ids) ((def-name ...) (generate-temporaries (map car int+ext-ids)))) (values - #'(:unit (import) (export (rename export-spec (def-name int-id) ...)) - (define def-name int-id) - ...) + (syntax-protect + #'(:unit (import) (export (rename export-spec (def-name int-id) ...)) + (define def-name int-id) + ...)) null (list (cadr tagged-export-sig)) '())))))) @@ -1853,17 +1886,18 @@ (((etag . esig) ...) e) (((deptag . depsig) ...) d) (contracted? contracted?)) - (quasisyntax/loc (error-syntax) - (begin - (define u #,exp) - (define-syntax name - (make-set!-transformer - (make-unit-info (quote-syntax u) - (list (cons 'itag (quote-syntax isig)) ...) - (list (cons 'etag (quote-syntax esig)) ...) - (list (cons 'deptag (quote-syntax depsig)) ...) - (quote-syntax name) - contracted?))))))))) + (syntax-protect + (quasisyntax/loc (error-syntax) + (begin + (define u #,exp) + (define-syntax name + (make-set!-transformer + (make-unit-info (quote-syntax u) + (list (cons 'itag (quote-syntax isig)) ...) + (list (cons 'etag (quote-syntax esig)) ...) + (list (cons 'deptag (quote-syntax depsig)) ...) + (quote-syntax name) + contracted?)))))))))) ((_) (raise-stx-err err-msg))))) @@ -1899,21 +1933,22 @@ (map check-helper tagged-export-infos)) (form (stx-car (error-syntax)))) (values - #`(let ([unit-tmp unit-exp]) - #,(syntax/loc #'unit-exp - (check-unit unit-tmp 'form)) - #,(syntax/loc #'unit-exp - (check-sigs unit-tmp - (vector-immutable - (cons 'import-name - (vector-immutable import-keys ...)) - ...) - (vector-immutable - (cons 'export-name - (vector-immutable export-keys ...)) - ...) - 'form)) - unit-tmp) + (syntax-protect + #`(let ([unit-tmp unit-exp]) + #,(syntax/loc #'unit-exp + (check-unit unit-tmp 'form)) + #,(syntax/loc #'unit-exp + (check-sigs unit-tmp + (vector-immutable + (cons 'import-name + (vector-immutable import-keys ...)) + ...) + (vector-immutable + (cons 'export-name + (vector-immutable export-keys ...)) + ...) + 'form)) + unit-tmp)) tagged-import-sigids tagged-export-sigids tagged-dep-sigids)))))) @@ -1976,9 +2011,10 @@ (export (export-tagged-sig-id [e.x e.c] ...) ...) dep #,@splicing-body-contract)))]) - (values - (syntax/loc stx - (contract unit-contract new-unit '(unit name) (current-contract-region) (quote name) (quote-srcloc name))) + (values + (syntax-protect + (syntax/loc stx + (contract unit-contract new-unit '(unit name) (current-contract-region) (quote name) (quote-srcloc name)))) isigs esigs deps))))] [(ic:import-clause/contract ec:export-clause/contract dep:dep-clause . bexps) (build-unit/contract @@ -2350,9 +2386,10 @@ (with-syntax ([u units] [(esig ...) esig] [(isig ...) isig]) - (if define? - (syntax/loc (error-syntax) (define-values/invoke-unit u (import isig ...) (export esig ...))) - (syntax/loc (error-syntax) (invoke-unit u (import isig ...))))))] + (syntax-protect + (if define? + (syntax/loc (error-syntax) (define-values/invoke-unit u (import isig ...) (export esig ...))) + (syntax/loc (error-syntax) (invoke-unit u (import isig ...)))))))] [(list? units) (let-values ([(isig esig) (imps/exps-from-units units exports)]) (with-syntax ([(new-unit) (generate-temporaries '(new-unit))] @@ -2366,13 +2403,14 @@ (export esig ...) (link unit ...))))]) u)]) - (if define? - (syntax/loc (error-syntax) - (define-values/invoke-unit u - (import isig ...) (export esig ...))) - (syntax/loc (error-syntax) - (invoke-unit u - (import isig ...)))))))] + (syntax-protect + (if define? + (syntax/loc (error-syntax) + (define-values/invoke-unit u + (import isig ...) (export esig ...))) + (syntax/loc (error-syntax) + (invoke-unit u + (import isig ...))))))))] ;; just for error handling [else (lookup-def-unit units)])) diff -Nru racket-7.2+ppa2/collects/setup/cross-system.rkt racket-7.3+ppa1/collects/setup/cross-system.rkt --- racket-7.2+ppa2/collects/setup/cross-system.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/setup/cross-system.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -26,9 +26,9 @@ ;; because cross-compiling requires the same VM. (eq? (system-type 'vm) (hash-ref ht 'vm #f)) - (for/and ([sym (in-list (list* - 'library-subpath - 'library-subpath-convention + (for/and ([sym (in-list (append + '(library-subpath + library-subpath-convention) system-type-symbols))]) (not (void? (hash-ref ht sym (void))))) (not diff -Nru racket-7.2+ppa2/collects/setup/dirs.rkt racket-7.3+ppa1/collects/setup/dirs.rkt --- racket-7.2+ppa2/collects/setup/dirs.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/setup/dirs.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -191,7 +191,9 @@ (combine-search (to-path (hash-ref (force host-config) 'lib-search-dirs #f)) (list (find-user-lib-dir) - (build-path - (exe-relative-path->complete-path (find-system-path 'host-collects-dir)) - 'up - "lib"))))) + (let ([coll-dir (exe-relative-path->complete-path + (find-system-path 'host-collects-dir))]) + (or (let ([p (hash-ref (force host-config) 'lib-dir #f)]) + (and p + (path->complete-path p coll-dir))) + (build-path coll-dir 'up "lib"))))))) diff -Nru racket-7.2+ppa2/collects/setup/main.rkt racket-7.3+ppa1/collects/setup/main.rkt --- racket-7.2+ppa2/collects/setup/main.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/setup/main.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -139,7 +139,8 @@ (if (member (car flags) ;; Flags that take 1 argument: '("--mode" "--doc-pdf" - "-j" "--jobs" "--workers")) + "-j" "--jobs" "--workers" + "--error-in" "--error-out")) (if (pair? (cdr flags)) (filter-flags queued-flags (cddr flags)) queued-flags) @@ -215,7 +216,7 @@ ;; 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. - (let-values ([(mk trust-zos) + (let-values ([(mk trust-zos managed-recompile-only) ;; Load cm.rkt into its own namespace, so that cm compiles ;; itself and its required modules in the right order ;; (i.e., when some module requires cm or one of its @@ -304,12 +305,17 @@ (dynamic-require 'compiler/private/cm-minimal 'make-compilation-manager-load/use-compiled-handler)] [trust-zos - (dynamic-require 'compiler/private/cm-minimal 'trust-existing-zos)]) - ;; Return the two extracted functions: - (lambda () (values mk trust-zos)))))))))]) + (dynamic-require 'compiler/private/cm-minimal 'trust-existing-zos)] + [managed-recompile-only + (dynamic-require 'compiler/private/cm-minimal 'managed-recompile-only)]) + ;; Return the extracted functions: + (lambda () (values mk trust-zos managed-recompile-only)))))))))]) (if (on? "--trust-zos") (trust-zos #t) (void)) + (if (on? "--recompile-only") + (managed-recompile-only #t) + (void)) (current-load/use-compiled (mk)))) ;; This has to be dynamic, so we get a chance to turn off diff -Nru racket-7.2+ppa2/collects/setup/option.rkt racket-7.3+ppa1/collects/setup/option.rkt --- racket-7.2+ppa2/collects/setup/option.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/setup/option.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -82,12 +82,15 @@ (define-flag-param always-check-dependencies #f) (define-flag-param fix-dependencies #f) (define-flag-param check-unused-dependencies #f) +(define-flag-param recompile-only #f) (define-flag-param call-install #t) (define-flag-param call-post-install #t) (define-flag-param pause-on-errors #f) (define-flag-param force-unpacks #f) (define-flag-param doc-pdf-dest #f) (define-flag-param fail-fast #f) +(define-flag-param next-error-out-file #f) +(define-flag-param previous-error-in-file #f) (define specific-collections (make-parameter null)) (define specific-packages (make-parameter null)) diff -Nru racket-7.2+ppa2/collects/setup/parallel-build.rkt racket-7.3+ppa1/collects/setup/parallel-build.rkt --- racket-7.2+ppa2/collects/setup/parallel-build.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/setup/parallel-build.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -12,6 +12,7 @@ racket/place syntax/modresolve "private/format-error.rkt" + "private/time.rkt" (for-syntax racket/base)) @@ -41,13 +42,13 @@ (wrkr/send wrkr (list 'compiled)) 'done] [(list w waitlst) - (hash-set! depends wrkr (cons w fn)) - (let ([fns (check-cycles wrkr (hash) null)]) + (let ([fns (check-cycles w (hasheq wrkr #t) null)]) (cond [fns (wrkr/send wrkr (list 'cycle (cons fn fns))) v] [else + (hash-set! depends wrkr (cons w fn)) (list w (append waitlst (list wrkr)))]))] [else (wrkr/send wrkr (list 'locked)) @@ -328,6 +329,9 @@ [current-compile-target-machine (if (memq 'compile-any options) #f (current-compile-target-machine))] + [managed-recompile-only (if (memq 'recompile-only options) + #t + (managed-recompile-only))] [current-load-relative-directory dir] [current-input-port (open-input-string "")] [current-output-port out-str-port] @@ -368,7 +372,8 @@ (define (parallel-compile worker-count setup-fprintf append-error collects-tree #:options [options '()] #:use-places? [use-places? #t]) - (setup-fprintf (current-output-port) #f "--- parallel build using ~a jobs ---" worker-count) + (setup-fprintf (current-output-port) #f (add-time + (format "--- parallel build using ~a jobs ---" worker-count))) (define collects-queue (make-object collects-queue% collects-tree setup-fprintf append-error (append options '(set-directory)))) (parallel-build collects-queue worker-count @@ -407,9 +412,14 @@ (define path (let loop ([prev prev]) (cond - [(submod? prev) - (loop (cadr prev))] - [else (resolve-module-path prev (build-path dir "dummy.rkt"))]))) + [(submod? prev) + (define base (cadr prev)) + (cond + [(or (equal? base "..") (equal? base ".")) + #f] + [else + (loop (cadr prev))])] + [else (resolve-module-path prev (build-path dir "dummy.rkt"))]))) (when (path? path) (send/add path))) p]))) diff -Nru racket-7.2+ppa2/collects/setup/private/pkg-deps.rkt racket-7.3+ppa1/collects/setup/private/pkg-deps.rkt --- racket-7.2+ppa2/collects/setup/private/pkg-deps.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/setup/private/pkg-deps.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -13,7 +13,8 @@ setup/dirs setup/doc-db version/utils - compiler/private/dep) + compiler/private/dep + "time.rkt") (provide check-package-dependencies) @@ -28,7 +29,7 @@ coll-paths coll-main?s coll-modes - setup-printf setup-fprintf + setup-printf setup-fprintf report-error check-unused? fix? verbose? all-pkgs-lazily? must-declare-deps?) @@ -369,32 +370,36 @@ (append (map path-element->string coll-path) (list base)) "/"))) (define zo-path (build-path dir zo-f)) - (define mod-code (call-with-input-file* - zo-path - (lambda (i) - (parameterize ([read-accept-compiled #t] - [read-on-demand-source zo-path]) - (read i))))) - ;; Recur to cover submodules: - (let loop ([mod-code mod-code]) - (define name (module-compiled-name mod-code)) - (unless (and (list? name) - (memq (last name) build-only-submod-names)) - ;; Check the module's imports: - (for* ([imports (in-list (module-compiled-imports mod-code))] - [import (cdr imports)]) - (define mod (let ([m (collapse-module-path-index import in-mod)]) - (if (and (pair? m) - (eq? (car m) 'submod)) - (cadr m) - m))) - (when (and (pair? mod) (eq? 'lib (car mod))) - (check-mod! mod 'run pkg zo-f dir))) - ;; Recur for submodules: - (for-each loop - (append - (module-compiled-submodules mod-code #t) - (module-compiled-submodules mod-code #f))))))) + (let/ec esc + (define mod-code (with-handlers ([exn:fail? (lambda (exn) + (report-error exn) + (esc (void)))]) + (call-with-input-file* + zo-path + (lambda (i) + (parameterize ([read-accept-compiled #t] + [read-on-demand-source zo-path]) + (read i)))))) + ;; Recur to cover submodules: + (let loop ([mod-code mod-code]) + (define name (module-compiled-name mod-code)) + (unless (and (list? name) + (memq (last name) build-only-submod-names)) + ;; Check the module's imports: + (for* ([imports (in-list (module-compiled-imports mod-code))] + [import (cdr imports)]) + (define mod (let ([m (collapse-module-path-index import in-mod)]) + (if (and (pair? m) + (eq? (car m) 'submod)) + (cadr m) + m))) + (when (and (pair? mod) (eq? 'lib (car mod))) + (check-mod! mod 'run pkg zo-f dir))) + ;; Recur for submodules: + (for-each loop + (append + (module-compiled-submodules mod-code #t) + (module-compiled-submodules mod-code #f)))))))) ;; ---------------------------------------- (define (find-compiled-directories path) @@ -569,7 +574,7 @@ (zero? (hash-count missing-pkgs)))) (unless all-ok? (setup-fprintf (current-error-port) #f - "--- summary of package problems ---") + (add-time "--- summary of package problems ---")) (for ([(pkg) (in-hash-keys missing-pkgs)]) (setup-fprintf* (current-error-port) #f "package not installed: ~a" diff -Nru racket-7.2+ppa2/collects/setup/private/time.rkt racket-7.3+ppa1/collects/setup/private/time.rkt --- racket-7.2+ppa2/collects/setup/private/time.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/collects/setup/private/time.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,20 @@ +#lang racket/base + +(provide add-time) + +(define (add-time s) + (define now (seconds->date (current-seconds))) + (string-append + s + (make-string (max 0 (- 55 (string-length s))) #\space) + (format "[~a:~a~a:~a~a]" + (date-hour now) + (if ((date-minute now) . < . 10) + "0" + "") + (date-minute now) + (if ((date-second now) . < . 10) + "0" + "") + (date-second now)))) + diff -Nru racket-7.2+ppa2/collects/setup/setup-cmdline.rkt racket-7.3+ppa1/collects/setup/setup-cmdline.rkt --- racket-7.2+ppa2/collects/setup/setup-cmdline.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/setup/setup-cmdline.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -80,6 +80,8 @@ (add-flags '((make-zo #f)))] [("--trust-zos") "Trust existing \".zo\"s (use only with prepackaged \".zo\"s)" (add-flags '((trust-existing-zos #t)))] + [("--recompile-only") "Fail if compilation must start from source" + (add-flags '((recompile-only #t)))] [("-x" "--no-launcher") "Do not produce launcher programs" (add-flags '((make-launchers #f)))] [("-F" "--no-foreign-libs") "Do not install foreign libraries" @@ -147,6 +149,10 @@ (add-flags `((compile-mode ,mode)))] [("--fail-fast") "Trigger a break on the first error" (add-flags '((fail-fast #t)))] + [("--error-out") file "On continuable error, create and exit as success" + (add-flags `((next-error-out-file ,file)))] + [("--error-in") file "Check for report of previous errors" + (add-flags `((previous-error-in-file ,file)))] [("-p" "--pause") "Pause at the end if there are any errors" (add-flags '((pause-on-errors #t)))] #:help-labels diff -Nru racket-7.2+ppa2/collects/setup/setup-core.rkt racket-7.3+ppa1/collects/setup/setup-core.rkt --- racket-7.2+ppa2/collects/setup/setup-core.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/setup/setup-core.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -40,6 +40,7 @@ "collection-name.rkt" "private/format-error.rkt" "private/encode-relative.rkt" + "private/time.rkt" compiler/private/dep (only-in pkg/lib pkg-directory pkg-single-collection)) @@ -201,14 +202,34 @@ (define (done) (unless (null? errors) - (setup-printf #f "--- summary of errors ---") + (setup-printf #f (add-time "--- summary of errors ---")) (show-errors (current-error-port)) (when (pause-on-errors) (eprintf "INSTALLATION FAILED.\nPress Enter to continue...\n") (read-line)) - (exit 1)) + (set! exit-code 1)) + (manage-prevous-and-next) (exit exit-code)) + (define (manage-prevous-and-next) + (define prev (previous-error-in-file)) + (when (and prev (file-exists? prev)) + (setup-printf #f (add-time "--- previous errors ---")) + (setup-printf #f "errors were~a reported by a previous process" + (if (zero? exit-code) "" " also")) + (set! exit-code 1)) + (define next (next-error-out-file)) + (when next + (cond + [(zero? exit-code) + (delete-directory/files next #:must-exist? #f)] + [else + (call-with-output-file* + next + #:exists 'truncate/replace + (lambda (o) (fprintf o "Errors reported\n"))) + (set! exit-code 0)]))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Archive Unpacking ;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -820,7 +841,7 @@ [else (void)]))))) (define (clean-step) - (setup-printf #f "--- cleaning collections ---") + (setup-printf #f (add-time "--- cleaning collections ---")) (define dependencies (make-hash)) ;; Main deletion: (for ([cc ccs-to-compile]) (clean-collection cc dependencies)) @@ -863,11 +884,12 @@ (define (do-install-part part) (when (if (eq? part 'post) (call-post-install) (call-install)) - (setup-printf #f (format "--- ~ainstalling collections ---" - (case part - [(pre) "pre-"] - [(general) ""] - [(post) "post-"]))) + (setup-printf #f (add-time + (format "--- ~ainstalling collections ---" + (case part + [(pre) "pre-"] + [(general) ""] + [(post) "post-"])))) (for ([cc ccs-to-call-installers]) (let/ec k (begin-record-error cc (case part @@ -1095,7 +1117,7 @@ #:group 'libs #:namespace info-ns)]) (lambda (p) (regexp-match? rx p)))) - (setup-printf #f "--- compiling collections ---") + (setup-printf #f (add-time "--- compiling collections ---")) (if ((parallel-workers) . > . 1) (begin (when (or no-specific-collections? @@ -1116,9 +1138,13 @@ (iterate-cct clean-cc cct) (parallel-compile (parallel-workers) setup-fprintf handle-error cct #:use-places? (parallel-use-places) - #:options (if (not (current-compile-target-machine)) - '(compile-any) - '())) + #:options (append + (if (not (current-compile-target-machine)) + '(compile-any) + '()) + (if (managed-recompile-only) + '(recompile-only) + '()))) (for/fold ([gcs 0]) ([cc planet-dirs-to-compile]) (compile-cc cc gcs has-module-suffix?))))) (with-specified-mode @@ -1133,7 +1159,7 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (make-info-domain-step) - (setup-printf #f "--- updating info-domain tables ---") + (setup-printf #f (add-time "--- updating info-domain tables ---")) ;; Each ht maps a collection root dir to an info-domain table. Even when ;; `collections-to-compile' is a subset of all collections, we only care ;; about those collections that exist in the same root as the ones in @@ -1375,7 +1401,7 @@ setup-printf)) (define (make-docs-step) - (setup-printf #f "--- building documentation ---") + (setup-printf #f (add-time "--- building documentation ---")) (set-doc:verbose) (with-handlers ([exn:fail? (lambda (exn) @@ -1388,7 +1414,7 @@ (doc:setup-scribblings #f auto-start-doc?))) (define (doc-pdf-dest-step) - (setup-printf #f "--- building PDF documentation (via pdflatex) ---") + (setup-printf #f (add-time "--- building PDF documentation (via pdflatex) ---")) (define dest-dir (path->complete-path (doc-pdf-dest))) (unless (directory-exists? dest-dir) (make-directory dest-dir)) @@ -1419,7 +1445,7 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (make-launchers-step) - (setup-printf #f "--- creating launchers ---") + (setup-printf #f (add-time "--- creating launchers ---")) (define (name-list l) (unless (list-of relative-path-string? l) (error "result is not a list of relative path strings:" l))) @@ -1724,7 +1750,7 @@ fixup-lib copy-user-lib) (define (make-libs-step) - (setup-printf #f (format "--- installing ~a ---" whats)) + (setup-printf #f (add-time (format "--- installing ~a ---" whats))) (define installed-libs (make-hash)) (define dests (make-hash)) (for ([cc ccs-to-compile]) @@ -1999,7 +2025,7 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (do-check-package-dependencies) - (setup-printf #f (format "--- checking package dependencies ---")) + (setup-printf #f (add-time (format "--- checking package dependencies ---"))) (unless (check-package-dependencies (map cc-path ccs-to-compile) (map cc-collection ccs-to-compile) (map cc-main? ccs-to-compile) @@ -2014,6 +2040,9 @@ 'build 'run)))) setup-printf setup-fprintf + (lambda (exn) + (set! exit-code 1) + (setup-printf #f "check failure: ~a" (exn->string exn))) (check-unused-dependencies) (fix-dependencies) (verbose) @@ -2027,7 +2056,9 @@ (setup-printf "version" "~a" (version)) (setup-printf "platform" "~a [~a]" (cross-system-library-subpath #f) (cross-system-type 'gc)) - (setup-printf "target machine" "~a" (or (current-compile-target-machine) 'any)) + (setup-printf "target machine" "~a" (or (current-compile-target-machine) + (cross-system-type 'target-machine) + 'any)) (when (cross-installation?) (setup-printf "cross-installation" "yes")) (setup-printf "installation name" "~a" (get-installation-name)) diff -Nru racket-7.2+ppa2/collects/setup/setup-go.rkt racket-7.3+ppa1/collects/setup/setup-go.rkt --- racket-7.2+ppa2/collects/setup/setup-go.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/setup/setup-go.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -31,6 +31,8 @@ (current-target-plt-directory-getter))] [trust-existing-zos (or (has-x-flag? 'trust-existing-zos) (trust-existing-zos))] + [managed-recompile-only (or (has-x-flag? 'recompile-only) + (managed-recompile-only))] [specific-collections x-specific-collections] [specific-packages x-specific-packages] [archives x-archives] diff -Nru racket-7.2+ppa2/collects/setup/setup.rkt racket-7.3+ppa1/collects/setup/setup.rkt --- racket-7.2+ppa2/collects/setup/setup.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/setup/setup.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -2,7 +2,8 @@ (require "option.rkt" "setup-core.rkt" launcher/launcher - compiler/compiler) + compiler/compiler + compiler/cm) (provide setup) @@ -19,7 +20,11 @@ #:avoid-main? [avoid-main? #f] #:force-user-docs? [force-user-docs? #f] #:jobs [parallel #f] - #:fail-fast? [fail-fast? #f]) + #:recompile-only? [recompile-only? #f] + #:fail-fast? [fail-fast? #f] + #:check-pkg-deps? [always-check-dependencies? #f] + #:fix-pkg-deps? [fix-dependencies? #f] + #:unused-pkg-deps? [check-unused-dependencies? #f]) (parameterize (;; Here's where we tell setup the archive file: [archives (if (or clean? (not file)) (archives) (list file))] @@ -57,9 +62,17 @@ [make-launchers (if clean? #f (make-launchers))] [make-info-domain (if clean? #t (make-info-domain))] [call-install (if clean? #f (call-install))] + + [fix-dependencies fix-dependencies?] + [check-unused-dependencies check-unused-dependencies?] + [always-check-dependencies (or fix-dependencies? + check-unused-dependencies? + always-check-dependencies?)] [setup-program-name "raco setup"] - + + [recompile-only recompile-only?] + [managed-recompile-only recompile-only?] [parallel-workers (if parallel parallel (parallel-workers))]) (let/ec esc diff -Nru racket-7.2+ppa2/collects/syntax/contract.rkt racket-7.3+ppa1/collects/syntax/contract.rkt --- racket-7.2+ppa2/collects/syntax/contract.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/syntax/contract.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1,7 +1,6 @@ #lang racket/base (require racket/contract/base (for-template racket/base - racket/contract/base syntax/location) syntax/srcloc syntax/modcollapse @@ -10,7 +9,8 @@ (provide/contract [wrap-expr/c (->* (syntax? syntax?) - (#:positive (or/c syntax? string? module-path-index? + (#:arg? any/c + #:positive (or/c syntax? string? module-path-index? 'from-macro 'use-site 'unknown) #:negative (or/c syntax? string? module-path-index? 'from-macro 'use-site 'unknown) @@ -19,30 +19,107 @@ #:context (or/c syntax? #f)) syntax?)]) -(module macro-arg/c racket/base - (require racket/contract/base - racket/contract/combinator) - - (provide macro-arg/c) - - (define (macro-arg/c macro-name ctc) - (let ([ctc-project (get/build-late-neg-projection (coerce-contract 'wrap-expr/c ctc))]) - ((cond [(flat-contract? ctc) make-flat-contract] - [(chaperone-contract? ctc) make-chaperone-contract] - [else make-contract]) - #:name (contract-name ctc) - #:first-order (contract-first-order ctc) - #:late-neg-projection - (λ (blame) - (let ([blame* (if macro-name (blame-add-context blame #f #:important macro-name) blame)]) - (ctc-project (blame-swap blame*)))) - #:list-contract? (list-contract? ctc))))) +(module runtime racket/base + (require (for-syntax racket/base + syntax/free-vars) + racket/contract/base + racket/contract/combinator + (only-in racket/contract/private/base + make-apply-contract)) + (provide expr/contract + relative-source) + + (define (macro-expr/c arg? expr-name ctc0) + (define ctc (coerce-contract 'wrap-expr/c ctc0)) + (define proj (get/build-late-neg-projection ctc)) + (make-contract + #:name (unquoted-printing-string + (format "macro ~a contract~a~a" + (if arg? "argument" "result") + (if expr-name " on " "") + (if expr-name expr-name ""))) + #:first-order (contract-first-order ctc) + #:late-neg-projection + (λ (blame) + (define blame* (blame-add-context blame (format "~s" (contract-name ctc)) #:swap? arg?)) + (proj (blame-swap blame))) + #:list-contract? (list-contract? ctc))) + + (define (macro-dep-expr/c arg? expr-name) + (make-contract + #:name (unquoted-printing-string + (format "macro ~a contract~a~a" + (if arg? "argument" "result") + (if expr-name " on " "") + (if expr-name expr-name ""))) + #:late-neg-projection + (lambda (blame) + (lambda (_f neg) + ;; Note: specialized to _f = return-second-arg. + (lambda (c v) + (define (slow-path) + (define ctc (coerce-contract 'wrap-expr/c c)) + (define proj (get/build-late-neg-projection ctc)) + (define blame* + (blame-add-context blame (format "~s" (contract-name ctc)) #:swap? arg?)) + ((proj blame*) v neg)) + (cond [(flat-contract? c) + (let ([c (if (procedure? c) c (coerce-contract 'wrap-expr/c c))]) + (if (c v) v (slow-path)))] + [else (slow-path)])))))) + + (define (return-second-arg c v) v) + + (begin-for-syntax + (define (okay-to-lift? ee) + (and (identifier? ee) (not (local-free-vars? ee)))) + (define (self-module-path-index? mpi) + (define-values (rel base) (module-path-index-split mpi)) + (and (eq? rel #f) (eq? (module-path-index-submodule mpi) #f))) + (define (local-free-vars? ee) + (for/or ([fv (in-list (free-vars ee #:module-bound? #t))]) + (define b (identifier-binding fv)) + (cond [(list? b) (self-module-path-index? (car b))] + [else #t])))) + + (define-syntax (expr/contract stx) + (cond + [(eq? (syntax-local-context) 'expression) + (syntax-case stx () + [(_ val-expr ctc-expr arg? expr-name [mac-arg ...]) + (let ([ctc-ee (local-expand #'ctc-expr 'expression null)]) + (cond [(okay-to-lift? ctc-ee) + #`(#,(syntax-local-lift-expression + #`(make-apply-contract + (macro-expr/c arg? expr-name #,ctc-ee) + mac-arg ...)) + val-expr)] + [else + #`(#,(syntax-local-lift-expression + #`((make-apply-contract + (macro-dep-expr/c arg? expr-name) + mac-arg ...) + return-second-arg)) + #,ctc-ee + val-expr)]))])] + [else #`(#%expression #,stx)])) -(require (for-template 'macro-arg/c)) + (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 "." runtime))) (define (wrap-expr/c ctc-expr expr - #:positive [pos-source 'use-site] - #:negative [neg-source 'from-macro] + #:arg? [arg? #t] + #:positive [pos-source 'from-macro] + #:negative [neg-source 'use-site] #:name [expr-name #f] #:macro [macro-name #f] #:context [ctx (current-syntax-context)]) @@ -63,32 +140,14 @@ (syntax-case ctx () [(x . _) (identifier? #'x) (syntax-e #'x)] [x (identifier? #'x) (syntax-e #'x)] - [_ #f])] - [else #f])]) - (base-wrap-expr/c expr #`(macro-arg/c '#,macro-name #,ctc-expr) - #:positive pos-source-expr - #:negative neg-source-expr - #:expr-name (cond [(and macro-name expr-name) - (format "~a of ~a" expr-name macro-name)] - [(or macro-name expr-name) - => (λ (name) (format "~a" name))] - [else #f]) - #:source #`(quote-syntax #,expr)))) - -(define (base-wrap-expr/c expr ctc-expr - #:positive positive - #:negative negative - #:expr-name expr-name - #:source source) - (let ([expr-name (or expr-name #'#f)] - [source (or source #'#f)]) - (quasisyntax/loc expr - (contract #,ctc-expr - #,expr - #,negative - #,positive - #,expr-name - #,source)))) + [_ '?])] + [else '?])]) + #`(expr/contract #,expr #,ctc-expr #,arg? '#,expr-name + [#,pos-source-expr + #,neg-source-expr + '#,macro-name + (quote-syntax #,expr) + #f]))) (define (get-source-expr source ctx) (cond [(eq? source 'use-site) @@ -128,17 +187,3 @@ (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-7.2+ppa2/collects/syntax/parse/debug.rkt racket-7.3+ppa1/collects/syntax/parse/debug.rkt --- racket-7.2+ppa2/collects/syntax/parse/debug.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/syntax/parse/debug.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -9,7 +9,9 @@ racket/pretty "../parse.rkt" (except-in syntax/parse/private/residual - prop:pattern-expander syntax-local-syntax-parse-pattern-introduce) + prop:syntax-class + prop:pattern-expander + syntax-local-syntax-parse-pattern-introduce) "private/runtime.rkt" "private/runtime-progress.rkt" "private/runtime-report.rkt" diff -Nru racket-7.2+ppa2/collects/syntax/parse/experimental/contract.rkt racket-7.3+ppa1/collects/syntax/parse/experimental/contract.rkt --- racket-7.2+ppa2/collects/syntax/parse/experimental/contract.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/syntax/parse/experimental/contract.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -10,8 +10,9 @@ (define not-given (gensym)) (define-syntax-class (expr/c ctc-stx - #:positive [pos-blame 'use-site] - #:negative [neg-blame 'from-macro] + #:arg? [arg? #t] + #:positive [pos-blame 'from-macro] + #:negative [neg-blame 'use-site] #:macro [macro-name #f] #:name [expr-name not-given] #:context [ctx #f]) @@ -21,6 +22,7 @@ #:with c (wrap-expr/c ctc-stx #'y + #:arg? arg? #:positive pos-blame #:negative neg-blame #:name (if (eq? expr-name not-given) @@ -31,7 +33,8 @@ (provide-syntax-class/contract [expr/c (syntax-class/c (syntax?) - (#:positive (or/c syntax? string? module-path-index? + (#:arg? any/c + #:positive (or/c syntax? string? module-path-index? 'from-macro 'use-site 'unknown) #:negative (or/c syntax? string? module-path-index? 'from-macro 'use-site 'unknown) diff -Nru racket-7.2+ppa2/collects/syntax/parse/private/lib.rkt racket-7.3+ppa1/collects/syntax/parse/private/lib.rkt --- racket-7.2+ppa2/collects/syntax/parse/private/lib.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/syntax/parse/private/lib.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -15,7 +15,7 @@ exact-integer exact-nonnegative-integer exact-positive-integer - + id nat char @@ -38,6 +38,8 @@ (define exact-integer-stx? (stxof exact-integer?)) (define exact-nonnegative-integer-stx? (stxof exact-nonnegative-integer?)) (define exact-positive-integer-stx? (stxof exact-positive-integer?)) +(define regexp-stx? (stxof regexp?)) +(define byte-regexp-stx? (stxof byte-regexp?)) ;; == Integrable syntax classes == @@ -59,10 +61,16 @@ (define-integrable-syntax-class -string (quote "string") string-stx?) (define-integrable-syntax-class -bytes (quote "bytes") bytes-stx?) +(define-integrable-syntax-class -regexp (quote "regexp") regexp-stx?) +(define-integrable-syntax-class -byte-regexp (quote "byte-regexp") byte-regexp-stx?) + +;; Overloading the meaning of existing identifiers (begin-for-syntax (set-box! alt-stxclass-mapping (list (cons #'string (syntax-local-value #'-string)) - (cons #'bytes (syntax-local-value #'-bytes))))) + (cons #'bytes (syntax-local-value #'-bytes)) + (cons #'regexp (syntax-local-value #'-regexp)) + (cons #'byte-regexp (syntax-local-value #'-byte-regexp))))) ;; Aliases (define-syntax id (make-rename-transformer #'identifier)) diff -Nru racket-7.2+ppa2/collects/syntax/parse/private/parse.rkt racket-7.3+ppa1/collects/syntax/parse/private/parse.rkt --- racket-7.2+ppa2/collects/syntax/parse/private/parse.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/syntax/parse/private/parse.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -54,11 +54,11 @@ (let-values ([(name formals arity) (let ([p (check-stxclass-header #'header stx)]) (values (car p) (cadr p) (caddr p)))]) - (let ([the-rhs (parse-rhs #'rhss splicing? #:context stx)]) + (let ([the-rhs (parse-rhs #'rhss splicing? #:context stx + #:default-description (symbol->string (syntax-e name)))]) (with-syntax ([name name] [formals formals] - [desc (cond [(rhs-description the-rhs) => constant-desc] - [else (symbol->string (syntax-e name))])] + [desc (cond [(rhs-description the-rhs) => constant-desc] [else #f])] [parser (generate-temporary (format-symbol "parse-~a" name))] [arity arity] [attrs (rhs-attrs the-rhs)] @@ -155,7 +155,7 @@ (with-syntax ([formals* formals*] [(def ...) defs] [((vdef ...) ...) vdefss] - [description (or description (symbol->string (syntax-e name)))] + [description description] [transparent? transparent?] [delimit-cut? delimit-cut?] [body body]) diff -Nru racket-7.2+ppa2/collects/syntax/parse/private/rep-data.rkt racket-7.3+ppa1/collects/syntax/parse/private/rep-data.rkt --- racket-7.2+ppa2/collects/syntax/parse/private/rep-data.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/syntax/parse/private/rep-data.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -225,10 +225,17 @@ ;; Stxclasses are primarily bound by env / syntax-local-value, but a few ;; are attached to existing bindings via alt-stxclass-mapping. (define (get-stxclass id [allow-undef? #f]) - (cond [(syntax-local-value/record id stxclass?) => values] - [(assoc id (unbox alt-stxclass-mapping) free-identifier=?) => cdr] - [allow-undef? #f] - [else (wrong-syntax id "not defined as syntax class")])) + (let loop ([id id] + [prev-ids '()]) + (cond [(syntax-local-value/record id stxclass?) => values] + [(syntax-local-value/record id has-stxclass-prop?) + => (lambda (val) + (define prop-val (stxclass-prop-ref val)) + (define prop-id (if (identifier? prop-val) prop-val (prop-val val))) + (loop prop-id (cons id prev-ids)))] + [(assoc id (unbox alt-stxclass-mapping) free-identifier=?) => cdr] + [allow-undef? #f] + [else (wrong-syntax id #:extra prev-ids "not defined as syntax class")]))) ;; check-stxclass-arity : stxclass Syntax Nat (Listof Keyword) -> Void (define (check-stxclass-arity sc stx pos-count keywords) diff -Nru racket-7.2+ppa2/collects/syntax/parse/private/rep-patterns.rkt racket-7.3+ppa1/collects/syntax/parse/private/rep-patterns.rkt --- racket-7.2+ppa2/collects/syntax/parse/private/rep-patterns.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/syntax/parse/private/rep-patterns.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -35,7 +35,7 @@ (pat:ord SinglePattern UninternedSymbol Nat) (pat:post SinglePattern) (pat:integrated id/#f id string stx) -* (pat:fixup Syntax Identifier/#f Identifier Identifier Arguments Syntax/#f Id/#f) +* (pat:fixup Syntax Identifier/#f Identifier Identifier Arguments String Syntax/#f Id/#f) * (pat:and/fixup Syntax (Listof *Pattern)) A ListPattern is a subtype of SinglePattern; one of @@ -68,7 +68,7 @@ (define-struct pat:ord (pattern group index) #:prefab) (define-struct pat:post (pattern) #:prefab) (define-struct pat:integrated (name predicate description role) #:prefab) -(define-struct pat:fixup (stx bind varname scname argu role parser*) #:prefab) +(define-struct pat:fixup (stx bind varname scname argu sep role parser*) #:prefab) (define-struct pat:and/fixup (stx patterns) #:prefab) #| @@ -265,7 +265,7 @@ (pattern-attrs sp)] [(pat:integrated name _ _ _) (if name (list (attr name 0 #t)) null)] - [(pat:fixup _ bind _ _ _ _ _) + [(pat:fixup _ bind _ _ _ _ _ _) (if bind (list (attr bind 0 #t)) null)] [(pat:and/fixup _ ps) (append-iattrs (map pattern-attrs ps))] @@ -352,7 +352,7 @@ [(pat:ord sp _ _) (pattern-has-cut? sp)] [(pat:post sp) (pattern-has-cut? sp)] [(pat:integrated name _ _ _) #f] - [(pat:fixup _ _ _ _ _ _ _) #t] + [(pat:fixup _ _ _ _ _ _ _ _) #t] [(pat:and/fixup _ ps) (ormap pattern-has-cut? ps)] ;; -- A patterns diff -Nru racket-7.2+ppa2/collects/syntax/parse/private/rep.rkt racket-7.3+ppa1/collects/syntax/parse/private/rep.rkt --- racket-7.2+ppa2/collects/syntax/parse/private/rep.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/syntax/parse/private/rep.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -29,9 +29,9 @@ (-> syntax? boolean?)] [parse-rhs - (-> syntax? boolean? - #:context (or/c false/c syntax?) - rhs?)] + (->* [syntax? boolean? #:context (or/c false/c syntax?)] + [#:default-description (or/c #f string?)] + rhs?)] [parse-pattern+sides (-> syntax? syntax? #:splicing? boolean? @@ -176,10 +176,14 @@ "identifier or syntax with leading identifier" x)])) +(define (propagate-disappeared! stx) + (cond [(and (syntax? stx) (syntax-property stx 'disappeared-use)) + => (lambda (xs) (record-disappeared-uses (filter identifier? (flatten xs)) #f))])) + ;; --- -;; parse-rhs : Syntax Boolean #:context Syntax -> RHS -(define (parse-rhs stx splicing? #:context ctx) +;; parse-rhs : Syntax Boolean #:context Syntax #:default-description (U String #f) -> RHS +(define (parse-rhs stx splicing? #:context ctx #:default-description [default-description #f]) (call/txlifts (lambda () (parameterize ((current-syntax-context ctx)) @@ -194,7 +198,7 @@ (or attributes (filter (lambda (a) (symbol-interned? (attr-name a))) (intersect-sattrss (map variant-attrs variants))))) - (make rhs sattrs transp? description variants + (make rhs sattrs transp? (or description #`(quote #,default-description)) variants (append (get-txlifts-as-definitions) defs) commit? delimit-cut?))))) @@ -252,7 +256,7 @@ (append/check-lits+litsets lits datum-lits litsets)) (define-values (convs-rules convs-defs) (for/fold ([convs-rules null] [convs-defs null]) - ([conv-entry (in-list convs)]) + ([conv-entry (in-list convs)]) (let* ([c (car conv-entry)] [argu (cdr conv-entry)] [get-parser-id (conventions-get-procedures c)] @@ -447,6 +451,7 @@ [else (wrong-syntax stx "action pattern not allowed here")])) (define not-shadowed? (make-not-shadowed? decls)) + (propagate-disappeared! stx) (check-pattern (syntax-case* stx (~var ~literal ~datum ~and ~or ~or* ~alt ~not ~rest ~describe ~seq ~optional ~! ~bind ~fail ~parse ~do ~undo @@ -622,6 +627,7 @@ (unless (stx-list? stx) (wrong-syntax stx "expected sequence of patterns")) (apply append (map recur (cdr (stx->list stx))))) (define not-shadowed? (make-not-shadowed? decls)) + (propagate-disappeared! stx) (syntax-case* stx (~eh-var ~or ~alt ~between ~optional ~once) (make-not-shadowed-id=? decls) [id @@ -696,7 +702,7 @@ (define entry (declenv-lookup decls suffix)) (cond [(or (den:lit? entry) (den:datum-lit? entry)) (pat:and (list (pat:svar name) (parse-pat:id/entry id allow-head? entry)))] - [else (parse-stxclass-use id allow-head? name suffix no-arguments #f)])])] + [else (parse-stxclass-use id allow-head? name suffix no-arguments "." #f)])])] [(declenv-apply-conventions decls id) => (lambda (entry) (parse-pat:id/entry id allow-head? entry))] [else (pat:svar id)])) @@ -733,13 +739,13 @@ [(den:datum-lit internal sym) (pat:datum sym)] [(den:magic-class name scname argu role) - (parse-stxclass-use scname allow-head? id scname argu role)] + (parse-stxclass-use scname allow-head? id scname argu "." role)] [(den:class _n _c _a) (error 'parse-pat:id "(internal error) decls had leftover stxclass entry: ~s" entry)] [(den:delayed parser scname) - (parse-stxclass-use id allow-head? id scname no-arguments #f parser)])) + (parse-stxclass-use id allow-head? id scname no-arguments "." #f parser)])) (define (parse-pat:var stx decls allow-head?) (define name0 @@ -773,24 +779,22 @@ [(and (wildcard? name0) (not scname)) (pat:any)] [scname - (parse-stxclass-use stx allow-head? name0 scname argu role)] + (parse-stxclass-use stx allow-head? name0 scname argu pfx role)] [else ;; Just proper name (pat:svar name0)])) ;; ---- -(define (parse-stxclass-use stx allow-head? varname scname argu role [parser* #f]) - (cond [(and (memq (stxclass-lookup-config) '(yes try)) (get-stxclass scname #t)) +(define (parse-stxclass-use stx allow-head? varname scname argu pfx role [parser* #f]) + (define config (stxclass-lookup-config)) + (cond [(and (memq config '(yes try)) (get-stxclass scname (eq? config 'try))) => (lambda (sc) (unless parser* (check-stxclass-arity sc stx (length (arguments-pargs argu)) (arguments-kws argu))) - (parse-stxclass-use* stx allow-head? varname sc argu "." role parser*))] - [(memq (stxclass-lookup-config) '(try no)) + (parse-stxclass-use* stx allow-head? varname sc argu pfx role parser*))] + [else (define bind (name->bind varname)) - (pat:fixup stx bind varname scname argu role parser*)] - [else (wrong-syntax scname "not defined as syntax class (config=~s)" - ;; XXX FIXME - (stxclass-lookup-config))])) + (pat:fixup stx bind varname scname argu pfx role parser*)])) ;; ---- @@ -1255,8 +1259,8 @@ (define (fixup p allow-head?) (define (I p) (fixup p allow-head?)) (match p - [(pat:fixup stx bind varname scname argu role parser*) - (parse-stxclass-use stx allow-head? varname scname argu role parser*)] + [(pat:fixup stx bind varname scname argu pfx role parser*) + (parse-stxclass-use stx allow-head? varname scname argu pfx role parser*)] ;; ---- ;; [(pat:any) ;; (pat:any)] @@ -1658,7 +1662,7 @@ (syntax->list #'(e ...))] [_ (raise-syntax-error #f "expected list of expressions and definitions" ctx stx)])) - + ;; Arguments and Arities ;; parse-argu : (listof stx) -> Arguments diff -Nru racket-7.2+ppa2/collects/syntax/parse/private/residual-ct.rkt racket-7.3+ppa1/collects/syntax/parse/private/residual-ct.rkt --- racket-7.2+ppa2/collects/syntax/parse/private/residual-ct.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/syntax/parse/private/residual-ct.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -11,6 +11,9 @@ (struct-out den:lit) (struct-out den:datum-lit) (struct-out den:delayed) + prop:syntax-class + has-stxclass-prop? + stxclass-prop-ref alt-stxclass-mapping log-syntax-parse-error log-syntax-parse-warning @@ -39,6 +42,9 @@ inline ;; Id/#f, reference to a predicate ) #:prefab) +(define-values [prop:syntax-class has-stxclass-prop? stxclass-prop-ref] + (make-struct-type-property 'syntax-class)) + ;; alt-stxclass-mapping : (boxof (listof (pair Identifier Stxclass))) ;; Maps existing bindings (can't use syntax-local-value mechanism) to stxclasses. ;; Uses alist to avoid residual dependence on syntax/id-table. diff -Nru racket-7.2+ppa2/collects/syntax/parse.rkt racket-7.3+ppa1/collects/syntax/parse.rkt --- racket-7.2+ppa2/collects/syntax/parse.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/syntax/parse.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -15,6 +15,8 @@ syntax/parse/private/residual-ct) (provide pattern-expander? (contract-out + [prop:syntax-class + (struct-type-property/c (or/c identifier? (-> any/c identifier?)))] [pattern-expander (-> (-> syntax? syntax?) pattern-expander?)] [prop:pattern-expander diff -Nru racket-7.2+ppa2/collects/syntax/transformer.rkt racket-7.3+ppa1/collects/syntax/transformer.rkt --- racket-7.2+ppa2/collects/syntax/transformer.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/syntax/transformer.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -4,17 +4,22 @@ (provide make-variable-like-transformer) +(struct variable-like-transformer [procedure] + #:property prop:procedure (struct-field-index procedure) + #:property prop:set!-transformer (struct-field-index procedure)) + (define (make-variable-like-transformer ref-stx [set!-handler #f]) - (unless (syntax? ref-stx) - (raise-type-error 'make-variable-like-transformer "syntax?" ref-stx)) + (unless (or (syntax? ref-stx) (procedure? ref-stx)) + (raise-type-error 'make-variable-like-transformer "(or/c syntax? procedure?)" ref-stx)) (unless (or (syntax? set!-handler) (procedure? set!-handler) (eq? set!-handler #f)) (raise-type-error 'make-variable-like-transformer "(or/c syntax? procedure? #f)" set!-handler)) - (make-set!-transformer + (variable-like-transformer (lambda (stx) (syntax-case stx (set!) [id (identifier? #'id) - ref-stx] + (cond [(procedure? ref-stx) (ref-stx stx)] + [else ref-stx])] [(set! id val) (cond [(procedure? set!-handler) (set!-handler stx)] diff -Nru racket-7.2+ppa2/collects/version/check.rkt racket-7.3+ppa1/collects/version/check.rkt --- racket-7.2+ppa2/collects/version/check.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/version/check.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -8,7 +8,8 @@ (define timeout 30) (define (url->port url) - (get-pure-port (string->url url))) + (get-pure-port (string->url url) + #:redirections 5)) (define error-value (case-lambda diff -Nru racket-7.2+ppa2/collects/xml/plist.rkt racket-7.3+ppa1/collects/xml/plist.rkt --- racket-7.2+ppa2/collects/xml/plist.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/collects/xml/plist.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -164,10 +164,20 @@ (cons `(assoc-pair ,(cadr key) ,(collapse-value value)) (collapse-assoc-pairs rest))))) +(define (convert-string-value x) + (cond [(string? x) + x] + [(integer? x) + (string (integer->char x))] + [else + (error 'read-plist "Illegal string value: ~e" x)])) + ; collapse-value : xexpr -> value (define (collapse-value value) (case (car value) - [(string) (cadr value)] + [(string) (apply string-append + (map convert-string-value + (cdr value)))] [(true false) value] [(integer real) (list (car value) (string->number (cadr value)))] [(dict) (collapse-dict value)] diff -Nru racket-7.2+ppa2/debian/changelog racket-7.3+ppa1/debian/changelog --- racket-7.2+ppa2/debian/changelog 2019-02-03 18:00:00.000000000 +0000 +++ racket-7.3+ppa1/debian/changelog 2019-05-15 18:00:00.000000000 +0000 @@ -1,9 +1,22 @@ -racket (7.2+ppa2-1~cosmic1) cosmic; urgency=medium +racket (7.3+ppa1-1~cosmic1) cosmic; urgency=medium * PPA release - * Applied extflvector-length patch from upstream - -- Asumu Takikawa Sun, 03 Feb 2019 10:00:00 -0800 + -- Asumu Takikawa Wed, 15 May 2019 10:00:00 -0800 + +racket (7.2+dfsg1-2) unstable; urgency=medium + + * Upload to unstable. + + -- David Bremner Tue, 19 Feb 2019 17:11:01 -0400 + +racket (7.2+dfsg1-1) experimental; urgency=medium + + * New upstream bugfix release. + * Bug fix: "Install Package doesn't work in DrRacket", thanks to + Mike Manilone (Closes: #922444). + + -- David Bremner Sat, 16 Feb 2019 20:59:49 -0400 racket (7.1+dfsg1-1) unstable; urgency=medium diff -Nru racket-7.2+ppa2/debian/patches/0001-fix-extflvector-length-for-platforms-where-it-s-not-.patch racket-7.3+ppa1/debian/patches/0001-fix-extflvector-length-for-platforms-where-it-s-not-.patch --- racket-7.2+ppa2/debian/patches/0001-fix-extflvector-length-for-platforms-where-it-s-not-.patch 2019-02-03 18:00:00.000000000 +0000 +++ racket-7.3+ppa1/debian/patches/0001-fix-extflvector-length-for-platforms-where-it-s-not-.patch 1970-01-01 00:00:00.000000000 +0000 @@ -1,27 +0,0 @@ -From 14765a8acd98d2f2a4f342094984a469c5b995cc Mon Sep 17 00:00:00 2001 -From: Matthew Flatt -Date: Sat, 2 Feb 2019 19:38:41 -0700 -Subject: [PATCH] fix extflvector-length for platforms where it's not inlined - -(cherry-picked from 80f84f2132233f8bcba05273cc23414caff8bd9c) ---- - src/racket/src/number.c | 6 +++++- - 1 file changed, 5 insertions(+), 1 deletion(-) - -diff --git a/src/racket/src/number.c b/src/racket/src/number.c -index 9c646d67b5..59d079d836 100644 ---- a/src/racket/src/number.c -+++ b/src/racket/src/number.c -@@ -1083,7 +1083,11 @@ void scheme_init_extfl_number(Scheme_Startup_Env *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 -+ if (MZ_LONG_DOUBLE_AVAIL_AND(1)) -+ flags = SCHEME_PRIM_IS_BINARY_INLINED; -+ else -+ flags = SCHEME_PRIM_SOMETIMES_INLINED; -+ SCHEME_PRIM_PROC_FLAGS(p) |= scheme_intern_prim_opt_flags(flags - | SCHEME_PRIM_PRODUCES_FIXNUM); - scheme_addto_prim_instance("extflvector-length", p, env); - diff -Nru racket-7.2+ppa2/debian/patches/series racket-7.3+ppa1/debian/patches/series --- racket-7.2+ppa2/debian/patches/series 2019-02-03 18:00:00.000000000 +0000 +++ racket-7.3+ppa1/debian/patches/series 1970-01-01 00:00:00.000000000 +0000 @@ -1,2 +0,0 @@ -# debian/source/git-patches exported from git by quilt-patches-deb-export-hook -0001-fix-extflvector-length-for-platforms-where-it-s-not-.patch diff -Nru racket-7.2+ppa2/etc/config.rktd racket-7.3+ppa1/etc/config.rktd --- racket-7.2+ppa2/etc/config.rktd 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/etc/config.rktd 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -#hash((build-stamp . "") (catalogs . ("https://download.racket-lang.org/releases/7.2/catalog/" #f)) (doc-search-url . "https://download.racket-lang.org/releases/7.2/doc/local-redirect/index.html")) +#hash((build-stamp . "") (catalogs . ("https://download.racket-lang.org/releases/7.3/catalog/" #f)) (doc-search-url . "https://download.racket-lang.org/releases/7.3/doc/local-redirect/index.html")) diff -Nru racket-7.2+ppa2/README racket-7.3+ppa1/README --- racket-7.2+ppa2/README 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/README 2019-05-16 01:29:07.000000000 +0000 @@ -3,7 +3,7 @@ This is the Racket | Source -distribution for version 7.2. +distribution for version 7.3. 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/7.2/catalog/ + https://download.racket-lang.org/releases/7.3/catalog/ is consulted first. Visit http://racket-lang.org/ for more Racket resources. diff -Nru racket-7.2+ppa2/share/pkgs/2d/info.rkt racket-7.3+ppa1/share/pkgs/2d/info.rkt --- racket-7.2+ppa2/share/pkgs/2d/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/2d/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/2d-doc/info.rkt racket-7.3+ppa1/share/pkgs/2d-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/2d-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/2d-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/2d-lib/info.rkt racket-7.3+ppa1/share/pkgs/2d-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/2d-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/2d-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.3"))) (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-7.2+ppa2/share/pkgs/algol60/info.rkt racket-7.3+ppa1/share/pkgs/algol60/info.rkt --- racket-7.2+ppa2/share/pkgs/algol60/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/algol60/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/at-exp-lib/info.rkt racket-7.3+ppa1/share/pkgs/at-exp-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/at-exp-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/at-exp-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/base/info.rkt racket-7.3+ppa1/share/pkgs/base/info.rkt --- racket-7.2+ppa2/share/pkgs/base/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/base/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (define collection (quote multi)) (define version "7.2") (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.3"))) (define collection (quote multi)) (define version "7.3") (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-7.2+ppa2/share/pkgs/cext-lib/info.rkt racket-7.3+ppa1/share/pkgs/cext-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/cext-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/cext-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/class-iop-lib/info.rkt racket-7.3+ppa1/share/pkgs/class-iop-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/class-iop-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/class-iop-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/compatibility/info.rkt racket-7.3+ppa1/share/pkgs/compatibility/info.rkt --- racket-7.2+ppa2/share/pkgs/compatibility/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/compatibility/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/compatibility-doc/info.rkt racket-7.3+ppa1/share/pkgs/compatibility-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/compatibility-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/compatibility-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/compatibility-lib/info.rkt racket-7.3+ppa1/share/pkgs/compatibility-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/compatibility-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/compatibility-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/compiler/info.rkt racket-7.3+ppa1/share/pkgs/compiler/info.rkt --- racket-7.2+ppa2/share/pkgs/compiler/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/compiler/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/compiler-lib/compiler/decompile.rkt racket-7.3+ppa1/share/pkgs/compiler-lib/compiler/decompile.rkt --- racket-7.2+ppa2/share/pkgs/compiler-lib/compiler/decompile.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/compiler-lib/compiler/decompile.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -191,7 +191,10 @@ null)))) (define (decompile-single-top b) - (define forms (decompile-linklet (hash-ref (linkl-bundle-table b) 0) #:just-body? #t)) + (define forms (let ([l (hash-ref (linkl-bundle-table b) 0 #f)]) + (if l + (decompile-linklet l #:just-body? #t) + '()))) (if (= (length forms) 1) (car forms) `(begin ,@forms))) @@ -266,12 +269,14 @@ (define-values ,_ (lambda ,_ (begin - (vector-copy! ,_ ,_ (let-values (((.inspector) #f)) - (deserialize .mpi-vector .inspector .bulk-binding-registry - ',num-mutables ',mutable-vec - ',num-shares ',share-vec - ',mutable-fill-vec - ',result-vec))) + (vector-copy! ,_ ,_ (let-values ([(.inspector) #f]) + (let-values ([(data) + '#(,mutable-vec ,share-vec ,mutable-fill-vec ,result-vec)]) + (deserialize .mpi-vector .inspector .bulk-binding-registry + ',num-mutables (,_ data 0) + ',num-shares (,_ data 1) + (,_ data 2) + (,_ data 3))))) ,_)))) (decompile-deserialize '.mpi-vector '.inspector '.bulk-binding-registry num-mutables mutable-vec @@ -279,7 +284,6 @@ mutable-fill-vec result-vec)] [else - (log-error ">> HERE ~.s" (strip-correlated expr)) (decompile-linklet l)])] [else (decompile-linklet l)])) @@ -755,7 +759,7 @@ (struct faslable-correlated-linklet (expr name) #:prefab) -(struct faslable-correlated (e source position line column span name) +(struct faslable-correlated (e source position line column span props) #:prefab) (define (strip-correlated v) diff -Nru racket-7.2+ppa2/share/pkgs/compiler-lib/compiler/demodularizer/gc.rkt racket-7.3+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/gc.rkt --- racket-7.2+ppa2/share/pkgs/compiler-lib/compiler/demodularizer/gc.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/gc.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -92,7 +92,14 @@ [(closure code gen-id) #t] [(inline-variant direct inline) #t] [(case-lam name clauses) #t] - [_ (lam? b)])) + [(let-one rhs body type unused?) + (and (pure? rhs) + (pure? body))] + [(seq forms) + (for/and ([form (in-list forms)]) + (pure? form))] + [_ (or (lam? b) + (void? b))])) (for ([b (in-list body)]) (match b @@ -114,7 +121,8 @@ (unless (or assume-pure? (pure? rhs)) (used-rhs!))] - [_ (used! b)])) + [_ (unless (pure? b) + (used! b))])) ;; Anything not marked as used at this point can be dropped (define new-internals @@ -152,7 +160,7 @@ [(def-values ids rhs) (for/or ([id (in-list ids)]) (eq? 'used (hash-ref used (toplevel-pos id) #f)))] - [else (not (void? b))])) + [else (not (pure? b))])) b)) (define new-body (remap-positions used-body diff -Nru racket-7.2+ppa2/share/pkgs/compiler-lib/compiler/demodularizer/merge.rkt racket-7.3+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/merge.rkt --- racket-7.2+ppa2/share/pkgs/compiler-lib/compiler/demodularizer/merge.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/compiler-lib/compiler/demodularizer/merge.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -120,15 +120,25 @@ #:application-hook (lambda (rator rands remap) ;; Check for a `(.get-syntax-literal! ')` call + ;; or a `(.set-transformer! ' )` 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)] + i))) + => (lambda (i) + (cond + [(and any-syntax-literals? + (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)] + [(and any-transformer-registers? + (eqv? transformer-register-pos (import-pos i))) + ;; This is a `(.set-transformer! ' )` call + (void)] + [else #f]))] [else #f])))))) (values body diff -Nru racket-7.2+ppa2/share/pkgs/compiler-lib/info.rkt racket-7.3+ppa1/share/pkgs/compiler-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/compiler-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/compiler-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/contract-profile/info.rkt racket-7.3+ppa1/share/pkgs/contract-profile/info.rkt --- racket-7.2+ppa2/share/pkgs/contract-profile/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/contract-profile/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/data/info.rkt racket-7.3+ppa1/share/pkgs/data/info.rkt --- racket-7.2+ppa2/share/pkgs/data/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/data/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/data-doc/data/scribblings/enumerate.scrbl racket-7.3+ppa1/share/pkgs/data-doc/data/scribblings/enumerate.scrbl --- racket-7.2+ppa2/share/pkgs/data-doc/data/scribblings/enumerate.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/data-doc/data/scribblings/enumerate.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -948,8 +948,11 @@ [small (and/c two-way-enum? flat-enum? finite-enum?)]) two-way-enum?]{ Returns a @tech{two way enumeration} like @racket[big] except - that the elements of @racket[small] are removed. See also - @racket[except/e]. This operation is the one from @citet[whats-the-difference]'s + that the elements of @racket[small] are removed. Every element + in @racket[small] must also be in @racket[big]. See also + @racket[except/e]. + + This operation is the one from @citet[whats-the-difference]'s paper on subtracting bijections. @examples[#:eval the-eval @@ -960,7 +963,7 @@ when the range of @racket[small] is a large set. When it is small, using @racket[except/e] performs better. - The two enumerations may also be in different orders. + The two enumerations may also be in different orders. @examples[#:eval the-eval (define (evens-below/e n) diff -Nru racket-7.2+ppa2/share/pkgs/data-doc/info.rkt racket-7.3+ppa1/share/pkgs/data-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/data-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/data-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/data-enumerate-lib/data/enumerate/lib.rkt racket-7.3+ppa1/share/pkgs/data-enumerate-lib/data/enumerate/lib.rkt --- racket-7.2+ppa2/share/pkgs/data-enumerate-lib/data/enumerate/lib.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/data-enumerate-lib/data/enumerate/lib.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -110,11 +110,26 @@ (length non-nums)))) [result enum?])] - [but-not/e - (-> two-way-enum? - (and/c finite-enum? flat-enum? two-way-enum?) - two-way-enum?)])) + (->i ([big (and/c flat-enum? two-way-enum?)] + [small (and/c finite-enum? flat-enum? two-way-enum?)]) + #:pre/desc (big small) (appears-to-be-a-subset? small big) + [result two-way-enum?])])) + +(define (appears-to-be-a-subset? small big) + (let/ec k + (cond + [(zero? (enum-count small)) #t] + [else + (define ctc (enum-contract big)) + (for ([_ (in-range 10)]) ;; check 10 elements of `small` + (define index (random (min 1000 (enum-count small)))) + (define ele (from-nat small index)) + (unless (ctc ele) + (k (list (format "index ~a in `small` produces:" index) + (format " ~e" ele) + " but that is not enumerated by `big`")))) + #t]))) (define listof/e-contract (->i ([e (simple-recursive?) diff -Nru racket-7.2+ppa2/share/pkgs/data-enumerate-lib/info.rkt racket-7.3+ppa1/share/pkgs/data-enumerate-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/data-enumerate-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/data-enumerate-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/data-lib/info.rkt racket-7.3+ppa1/share/pkgs/data-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/data-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/data-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/datalog/info.rkt racket-7.3+ppa1/share/pkgs/datalog/info.rkt --- racket-7.2+ppa2/share/pkgs/datalog/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/datalog/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/db/info.rkt racket-7.3+ppa1/share/pkgs/db/info.rkt --- racket-7.2+ppa2/share/pkgs/db/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/db/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/db-doc/db/scribblings/query.scrbl racket-7.3+ppa1/share/pkgs/db-doc/db/scribblings/query.scrbl --- racket-7.2+ppa2/share/pkgs/db-doc/db/scribblings/query.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/db-doc/db/scribblings/query.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -853,5 +853,11 @@ it must return a @tech{statement}. } +@defproc[(prop:statement? [v any/c]) boolean?]{ + +Returns @racket[#t] if @racket[v] is an instance of a struct +implementing @racket[prop:statement], @racket[#f] otherwise. + +@history[#:added "1.5"]} @(close-eval the-eval) diff -Nru racket-7.2+ppa2/share/pkgs/db-doc/info.rkt racket-7.3+ppa1/share/pkgs/db-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/db-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/db-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.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" "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.3"))) (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-7.2+ppa2/share/pkgs/db-lib/db/base.rkt racket-7.3+ppa1/share/pkgs/db-lib/db/base.rkt --- racket-7.2+ppa2/share/pkgs/db-lib/db/base.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/db-lib/db/base.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -225,6 +225,7 @@ (#:value-mode group-mode/c) dict?)] ) +(provide prop:statement?) ;; ============================================================ diff -Nru racket-7.2+ppa2/share/pkgs/db-lib/db/private/mysql/connection.rkt racket-7.3+ppa1/share/pkgs/db-lib/db/private/mysql/connection.rkt --- racket-7.2+ppa2/share/pkgs/db-lib/db/private/mysql/connection.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/db-lib/db/private/mysql/connection.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -312,7 +312,8 @@ (cond [(statement-binding? stmt) (let* ([pst (statement-binding-pst stmt)] [id (send pst get-handle)] - [params (statement-binding-params stmt)] + [params (map (lambda (p) (if (sql-null? p) '(null . #f) p)) + (statement-binding-params stmt))] [param-count (length params)] [null-map (for/list ([p (in-list params)]) (eq? (car p) 'null))] [flags (if cursor? '(cursor/read-only) '())]) diff -Nru racket-7.2+ppa2/share/pkgs/db-lib/db/private/mysql/dbsystem.rkt racket-7.3+ppa1/share/pkgs/db-lib/db/private/mysql/dbsystem.rkt --- racket-7.2+ppa2/share/pkgs/db-lib/db/private/mysql/dbsystem.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/db-lib/db/private/mysql/dbsystem.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -73,10 +73,9 @@ ;; long-data are replaced by #f. ;; check-param : Symbol Any -> CheckParam-v1 +;; Note: not applied to sql-null parameters. (define (check-param fsym param) - (cond [(sql-null? param) - (cons 'null #f)] - [(string? param) + (cond [(string? param) (cons 'var-string (string->bytes/utf-8 param))] [(bytes? param) (cons 'blob param)] diff -Nru racket-7.2+ppa2/share/pkgs/db-lib/info.rkt racket-7.3+ppa1/share/pkgs/db-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/db-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/db-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.3"))) (define version "1.5") (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-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/convert-explicit.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/convert-explicit.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/convert-explicit.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/convert-explicit.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,12 +0,0 @@ -#lang scheme/base -(provide convert-explicit) - -(require mzlib/pretty - mzlib/struct) - -(require "private/explicit-write.rkt") - -(require deinprogramm/signature/signature-german) - -(require scheme/include) -(include "convert-explicit.scm") diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/convert-explicit.scm racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/convert-explicit.scm --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/convert-explicit.scm 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/convert-explicit.scm 1970-01-01 00:00:00.000000000 +0000 @@ -1,47 +0,0 @@ -; I HATE DEFINE-STRUCT! -(define-struct/properties :empty-list () - ((prop:custom-write - (lambda (r port write?) - (write-string "#" port)))) - (make-inspector)) - -;; might be improper -(define-struct/properties :list (elements) - ((prop:custom-write (make-constructor-style-printer - (lambda (obj) 'list) - (lambda (obj) (:list-elements obj))))) - (make-inspector)) - -(define (convert-explicit v) - (let ((hash (make-hasheq))) - (let recur ((v v)) - (cond - ((null? v) (make-:empty-list)) ; prevent silly printing of sharing - ((pair? v) - (make-:list - (let list-recur ((v v)) - (cond - ((null? v) - v) - ((not (pair? v)) - '()) ; the stepper feeds all kinds of garbage in here - (else - (cons (recur (car v)) - (list-recur (cdr v)))))))) - ((struct? v) - (or (hash-ref hash v #f) - (let-values (((ty skipped?) (struct-info v))) - (cond - ((and ty (lazy-wrap? ty)) - (let ((lazy-wrap-info (lazy-wrap-ref ty))) - (let ((constructor (lazy-wrap-info-constructor lazy-wrap-info)) - (raw-accessors (lazy-wrap-info-raw-accessors lazy-wrap-info))) - (let ((val (apply constructor (map (lambda (raw-accessor) - (recur (raw-accessor v))) - raw-accessors)))) - (hash-set! hash v val) - val)))) - (else v))))) - (else - v))))) - diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/define-record-procedures.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/define-record-procedures.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/define-record-procedures.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/define-record-procedures.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,25 +0,0 @@ -#lang scheme/base - -(provide define-record-procedures - define-record-procedures-parametric - define-record-procedures-2 - define-record-procedures-parametric-2) - -(require scheme/include - scheme/promise - mzlib/struct - mzlib/pconvert-prop - mzlib/pretty - deinprogramm/signature/signature - deinprogramm/signature/signature-german - deinprogramm/signature/signature-syntax - (only-in deinprogramm/quickcheck/quickcheck arbitrary-record arbitrary-one-of)) - -(require "private/explicit-write.rkt") - -(require (for-syntax scheme/base) - (for-syntax deinprogramm/syntax-checkers) - (for-syntax stepper/private/syntax-property) - (for-syntax racket/struct-info) - (for-syntax syntax/struct)) -(include "define-record-procedures.scm") diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/define-record-procedures.scm racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/define-record-procedures.scm --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/define-record-procedures.scm 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/define-record-procedures.scm 1970-01-01 00:00:00.000000000 +0000 @@ -1,626 +0,0 @@ -(define any (signature any %any)) - -(define-syntax define-record-procedures* - - (let () - (define (filter-map proc l) - (if (null? l) - '() - (let ((result (proc (car l)))) - (if result - (cons result (filter-map proc (cdr l))) - (filter-map proc (cdr l)))))) - - - (define (syntax-member? thing stuff) - (cond - ((null? stuff) #f) - ((free-identifier=? thing (car stuff)) #t) - (else (syntax-member? thing (cdr stuff))))) - - (define (map-with-index proc list) - (let loop ((i 0) (list list) (rev-result '())) - (if (null? list) - (reverse rev-result) - (loop (+ 1 i) - (cdr list) - (cons (proc i (car list)) rev-result))))) - - (lambda (x) - (syntax-case x () - ((_ ?stx - ?type-name - ?mutable? - ?signature-constructor-name - ?constructor - ?predicate - (?field-spec ...)) - - (with-syntax - ((number-of-fields (length (syntax->list (syntax (?field-spec ...))))) - ((accessor ...) - (map (lambda (field-spec) - (syntax-case field-spec () - ((accessor mutator signature) #'accessor))) - (syntax->list (syntax (?field-spec ...))))) - ((mutator ...) - (map (lambda (field-spec) - (syntax-case field-spec () - ((accessor mutator signature) #'mutator))) - (syntax->list (syntax (?field-spec ...)))))) - (let ((maybe-field-signatures - (map (lambda (field-spec) - (syntax-case field-spec () - ((accessor mutator #f) #f) - ((accessor mutator sig) #'sig))) - (syntax->list (syntax (?field-spec ...)))))) - (with-syntax - (((field-signature ...) - (map (lambda (sig) (or sig #'any)) maybe-field-signatures)) - ((accessor-proc ...) - (map-with-index - (lambda (i accessor) - (with-syntax ((i i) - (tag accessor)) - (syntax-property (syntax/loc - accessor - (lambda (s) - (when (not (raw-predicate s)) - (raise - (make-exn:fail:contract - (string->immutable-string - (format "~a: Argument kein ~a: ~e" - 'tag '?type-name s)) - (current-continuation-marks)))) - (raw-generic-access s i))) - 'inferred-name - (syntax-e accessor)))) - (syntax->list #'(accessor ...)))) - ((our-accessor ...) (generate-temporaries #'(accessor ...))) - (real-constructor - ;; use a different name for the value binding, but - ;; make sure the stepper prints the one from the d-r-p form - (let ((name #`?constructor)) - (stepper-syntax-property - (datum->syntax - #f - (string->uninterned-symbol - (symbol->string (syntax-e name)))) - 'stepper-orig-name - name))) - ((mutator-proc ...) - (map-with-index - (lambda (i mutator) - (with-syntax ((i i) - (tag mutator)) - (syntax-property (syntax/loc - mutator - (lambda (s v) - (when (not (raw-predicate s)) - (raise - (make-exn:fail:contract - (string->immutable-string - (format "~a: Argument kein ~a: ~e" - 'tag '?type-name s)) - (current-continuation-marks)))) - (raw-generic-mutate s i v))) - 'inferred-name - (syntax-e mutator)))) - (syntax->list #'(mutator ...)))) - (constructor-proc - (syntax-property #'(lambda (accessor ...) - (raw-constructor accessor ... #f)) - 'inferred-name - (syntax-e #'?constructor))) - (predicate-proc - (syntax-property #'(lambda (thing) - (raw-predicate thing)) - 'inferred-name - (syntax-e #'?predicate))) - ((raw-accessor-proc ...) - (map-with-index (lambda (i _) - #`(lambda (r) - (raw-generic-access r #,i))) - (syntax->list #'(?field-spec ...)))) - ((raw-mutator-proc ...) - (map-with-index (lambda (i _) - #`(lambda (r val) - (raw-generic-mutate r #,i val))) - (syntax->list #'(?field-spec ...)))) - - (record-equal? #`(lambda (r1 r2 equal?) - (and #,@(map-with-index (lambda (i field-spec) - #`(equal? (raw-generic-access r1 #,i) - (raw-generic-access r2 #,i))) - (syntax->list #'(?field-spec ...))))))) - - - (with-syntax - ((struct-type-defs - #'(define-values (type-descriptor - raw-constructor - raw-predicate - raw-generic-access - raw-generic-mutate) - (make-struct-type - '?type-name #f (+ 1 number-of-fields) 0 - #f - (list - (cons prop:print-convert-constructor-name - '?constructor) - (cons prop:custom-write - (make-constructor-style-printer - (lambda (obj) - (string->symbol (string-append "record:" (symbol->string '?type-name)))) - (lambda (obj) - (access-record-fields obj raw-generic-access number-of-fields)))) - (cons prop:print-converter - (lambda (r recur) - (list '?constructor - (recur (raw-accessor-proc r)) ...))) - (cons prop:equal+hash - (list record-equal? - (make-equal-hash (lambda (r i) (raw-generic-access r i)) number-of-fields) - (make-equal2-hash (lambda (r i) (raw-generic-access r i)) number-of-fields))) - (cons prop:lazy-wrap - (make-lazy-wrap-info constructor-proc - (list raw-accessor-proc ...) - (list raw-mutator-proc ...) - (lambda (r) - (raw-generic-access r number-of-fields)) - (lambda (r val) - (raw-generic-mutate r number-of-fields val))))) - (make-inspector)))) - (real-constructor-def #'(define/signature real-constructor - (signature (field-signature ... -> ?type-name)) - constructor-proc)) - (constructor-def #'(define-syntax ?constructor - (let () - (define-struct info () - #:super struct:struct-info - ;; support `signature' - #:property - prop:procedure - (lambda (_ stx) - (syntax-case stx () - [(self . args) (syntax/loc stx (real-constructor . args))] - [else (syntax/loc stx real-constructor)]))) - (make-info (lambda () - (list #f - #'real-constructor - #'real-predicate - (reverse (syntax->list #'(our-accessor ...))) - (map (lambda (_) #f) (syntax->list #'(our-accessor ...))) - #f)))))) - (predicate-def #'(define-values (?predicate real-predicate) - (values predicate-proc predicate-proc))) - (accessor-defs #'(define-values (accessor ... our-accessor ...) - (values accessor-proc ... accessor-proc ...))) - (mutator-defs #'(define-values (mutator ...) (values mutator-proc ...))) - (signature-def - (with-syntax (((?param ...) (generate-temporaries #'(?field-spec ...)))) - (with-syntax (((component-signature ...) - (map (lambda (accessor param) - (with-syntax ((?accessor accessor) - (?param param)) - #'(at ?param (property ?accessor ?param)))) - (syntax->list #'(our-accessor ...)) - (syntax->list #'(?param ...))))) - (with-syntax ((base-signature - (stepper-syntax-property - #`(define ?type-name - #,(cond - ((null? maybe-field-signatures) - #'(let ((sig (signature ?type-name (predicate real-predicate)))) - (set-signature-arbitrary-promise! - sig - (delay (arbitrary-one-of equal? (real-constructor)))) - sig)) - ((andmap values maybe-field-signatures) ; monomorphic - #'(let* ((sigs (list (signature field-signature) ...)) - (sig - (make-lazy-wrap-signature '?type-name #t - type-descriptor raw-predicate - sigs - #'?type-name))) - (set-signature-arbitrary-promise! - sig - (delay - (let ((arbs (map signature-arbitrary sigs))) - (when (andmap values arbs) - (apply arbitrary-record - real-constructor - (list raw-accessor-proc ...) - arbs))))) - sig)) - (else - #'(signature ?type-name (predicate real-predicate))))) - 'stepper-skip-completely - #t)) - (constructor-signature - (stepper-syntax-property - (if (syntax->datum #'?mutable?) - ;; no lazy signatures - #'(define (?signature-constructor-name ?param ...) - (signature - (combined (at ?type-name (predicate real-predicate)) - component-signature ...))) - ;; lazy signatures - #'(define (?signature-constructor-name ?param ...) - (let* ((sigs (list ?param ...)) - (sig - (make-lazy-wrap-signature '?type-name #t - type-descriptor raw-predicate - sigs - #'?type-name))) - (set-signature-arbitrary-promise! - sig - (delay - (let ((arbs (map signature-arbitrary sigs))) - (when (andmap values arbs) - (apply arbitrary-record - real-constructor - (list raw-accessor-proc ...) - arbs))))) - sig))) - 'stepper-skip-completely - #t))) - #'(begin - ;; we use real-predicate to avoid infinite recursion if a signature - ;; for ?type-name using ?predicate is inadvertently defined - base-signature - constructor-signature)))))) - ;; again, with properties - (with-syntax ((struct-type-defs - (stepper-syntax-property - (syntax/loc x struct-type-defs) 'stepper-black-box-expr #'?stx)) - (real-constructor-def - (stepper-syntax-property #'real-constructor-def 'stepper-skip-completely #t)) - (predicate-def - (stepper-syntax-property #'predicate-def 'stepper-skip-completely #t)) - (accessor-defs - (stepper-syntax-property #'accessor-defs 'stepper-skip-completely #t)) - (mutator-defs - (stepper-syntax-property #'mutator-defs 'stepper-skip-completely #t))) - #'(begin - struct-type-defs - signature-def - ;; the signature might be used in the definitions, hence this ordering - predicate-def real-constructor-def constructor-def accessor-defs mutator-defs))))))) - ((_ ?type-name - ?signature-constructor-name - ?constructor - ?predicate - rest) - (raise-syntax-error - #f - "Der vierte Operand ist illegal" (syntax rest))) - ((_ ?type-name - ?signature-constructor-name - ?constructor - ?predicate - rest1 rest2 ... (?field-spec ...)) - (raise-syntax-error - #f - "Vor den Selektoren/Mutatoren steht eine Form zuviel" #'rest1)) - ((_ ?type-name - ?signature-constructor-name - ?constructor - ?predicate - rest1 rest2 ...) - (raise-syntax-error - #f - "Zu viele Operanden für define-record-procedures*" x)) - ((_ arg1 ...) - (raise-syntax-error - #f - "Zu wenige Operanden für define-record-procedures*" x)))))) - -(define (access-record-fields rec acc count) - (let recur ((i 0)) - (if (= i count) - '() - (cons (acc rec i) - (recur (+ i 1)))))) - -(define (make-equal-hash generic-access field-count) - (lambda (r recur) - (let loop ((i 0) - (factor 1) - (hash 0)) - (if (= i field-count) - hash - (loop (+ 1 i) - (* factor 33) - (+ hash (* factor (recur (generic-access r i))))))))) - -(define (make-equal2-hash generic-access field-count) - (lambda (r recur) - (let loop ((i 0) - (factor 1) - (hash 0)) - (if (= i field-count) - hash - (loop (+ 1 i) - (* factor 33) - (+ hash (* factor - (recur (generic-access r (- field-count i 1)))))))))) - -;; (define-record-procedures :pare kons pare? (kar kdr)) - -(define-syntax define-record-procedures - (lambda (x) - (syntax-case x () - ((_ ?type-name - ?constructor - (?field-spec ...)) - (syntax - (define-record-procedures ?type-name ?constructor dummy-predicate (?field-spec ...)))) - - ((_ ?type-name - ?constructor - ?predicate - (?field-spec ...)) - - (begin - (check-for-id! - (syntax ?type-name) - "Typ-Name ist kein Bezeichner") - - (check-for-id! - (syntax ?constructor) - "Konstruktor ist kein Bezeichner") - - (check-for-id! - (syntax ?predicate) - "Prädikat ist kein Bezeichner") - - (with-syntax ((?stx x) - (field-specs - (map - (lambda (field-spec dummy-mutator) - (syntax-case field-spec () - ((accessor signature) - (begin - (check-for-id! (syntax accessor) - "Selektor ist kein Bezeichner") - #`(accessor #,dummy-mutator signature))) - (accessor - (begin - (check-for-id! (syntax accessor) - "Selektor ist kein Bezeichner") - #`(accessor #,dummy-mutator #f))))) - (syntax->list #'(?field-spec ...)) - (generate-temporaries #'(?field-spec ...))))) - (syntax - (define-record-procedures* ?stx ?type-name #f - dummy-signature-constructor-name - ?constructor - ?predicate - field-specs))))) - - ((_ ?type-name - ?constructor - ?predicate - rest) - (raise-syntax-error - #f - "Der vierte Operand ist keine Liste von Selektoren" (syntax rest))) - ((_ ?type-name - ?constructor - ?predicate - rest1 rest2 ... (accessor ...)) - (raise-syntax-error - #f - "Vor den Selektoren steht eine Form zuviel" #'rest1)) - ((_ ?type-name - ?constructor - ?predicate - rest1 rest2 ...) - (raise-syntax-error - #f - "Zu viele Operanden für define-record-procedures" x)) - ((_ arg1 ...) - (raise-syntax-error - #f - "Zu wenige Operanden für define-record-procedures" x)) - ))) - -(define-syntax define-record-procedures-parametric - (lambda (x) - (syntax-case x () - ((_ ?type-name - ?signature-constructor-name - ?constructor - ?predicate - (accessor ...)) - - - (begin - (check-for-id! - (syntax ?type-name) - "Record-Name ist kein Bezeichner") - - (check-for-id! - (syntax ?signature-constructor-name) - "Signaturkonstruktor-Name ist kein Bezeichner") - - (check-for-id! - (syntax ?constructor) - "Konstruktor ist kein Bezeichner") - - (check-for-id! - (syntax ?predicate) - "Prädikat ist kein Bezeichner") - - (check-for-id-list! - (syntax->list (syntax (accessor ...))) - "Selektor ist kein Bezeichner") - - (with-syntax ((?stx x) - ((dummy-mutator ...) - (generate-temporaries (syntax (accessor ...))))) - (syntax - (define-record-procedures* ?stx ?type-name #f ?signature-constructor-name - ?constructor - ?predicate - ((accessor dummy-mutator #f) ...)))))) - - ((_ ?type-name - ?signature-constructor-name - ?constructor - ?predicate - rest) - (raise-syntax-error - #f - "Der vierte Operand ist keine Liste von Selektoren" (syntax rest))) - ((_ ?type-name - ?signature-constructor-name - ?constructor - ?predicate - rest1 rest2 ...) - (raise-syntax-error - #f - "Zu viele Operanden für define-record-procedures-parametric" x)) - ((_ arg1 ...) - (raise-syntax-error - #f - "Zu wenige Operanden für define-record-procedures-parametric" x)) - ))) - -;; (define-record-procedures-2 :pare kons pare? ((kar set-kar!) kdr)) - -(define-syntax define-record-procedures-2 - (lambda (x) - (syntax-case x () - ((_ ?type-name - ?constructor - ?predicate - (?field-spec ...)) - - (begin - (check-for-id! - (syntax ?type-name) - "Record-Name ist kein Bezeichner") - - (check-for-id! - (syntax ?constructor) - "Konstruktor ist kein Bezeichner") - - (check-for-id! - (syntax ?predicate) - "Prädikat ist kein Bezeichner") - - (with-syntax ((?stx x) - (field-specs - (map - (lambda (field-spec dummy-mutator) - (syntax-case field-spec () - ((accessor mutator signature) - (begin - (check-for-id! (syntax accessor) - "Selektor ist kein Bezeichner") - #'(accessor mutator signature))) - ((accessor mutator) - (begin - (check-for-id! (syntax accessor) - "Selektor ist kein Bezeichner") - #'(accessor mutator #f))) - (accessor - (begin - (check-for-id! (syntax accessor) - "Selektor ist kein Bezeichner") - #`(accessor #,dummy-mutator #f))))) - (syntax->list #'(?field-spec ...)) - (generate-temporaries #'(?field-spec ...))))) - #'(define-record-procedures* ?stx ?type-name #t - dummy-signature-constructor-name - ?constructor - ?predicate - field-specs)))) - ((_ ?type-name - ?constructor - ?predicate - rest) - (raise-syntax-error - #f - "Der vierte Operand ist illegal" (syntax rest))) - ((_ ?type-name - ?constructor - ?predicate - rest1 rest2 ...) - (raise-syntax-error - #f - "Zu viele Operanden für define-record-procedures-2" x)) - ((_ arg1 ...) - (raise-syntax-error - #f - "Zu wenige Operanden für define-record-procedures-2" x))))) - -(define-syntax define-record-procedures-parametric-2 - (lambda (x) - (syntax-case x () - ((_ ?type-name - ?signature-constructor-name - ?constructor - ?predicate - (?field-spec ...)) - - (begin - (check-for-id! - (syntax ?type-name) - "Record-Name ist kein Bezeichner") - - (check-for-id! - (syntax ?signature-constructor-name) - "Signaturkonstruktor-Name ist kein Bezeichner") - - (check-for-id! - (syntax ?constructor) - "Konstruktor ist kein Bezeichner") - - (check-for-id! - (syntax ?predicate) - "Prädikat ist kein Bezeichner") - - (with-syntax ((?stx x) - (field-specs - (map - (lambda (field-spec dummy-mutator) - (syntax-case field-spec () - ((accessor mutator) - (begin - (check-for-id! (syntax accessor) - "Selektor ist kein Bezeichner") - #'(accessor mutator #f))) - (accessor - (begin - (check-for-id! (syntax accessor) - "Selektor ist kein Bezeichner") - #`(accessor #,dummy-mutator #f))))) - (syntax->list #'(?field-spec ...)) - (generate-temporaries #'(?field-spec ...))))) - #'(define-record-procedures* ?stx ?type-name #t ?signature-constructor-name - ?constructor - ?predicate - field-specs)))) - ((_ ?type-name - ?signature-constructor-name - ?constructor - ?predicate - rest) - (raise-syntax-error - #f - "Der vierte Operand ist illegal" (syntax rest))) - ((_ ?type-name - ?signature-constructor-name - ?constructor - ?predicate - rest1 rest2 ...) - (raise-syntax-error - #f - "Zu viele Operanden für define-record-procedures-parametric-2" x)) - ((_ arg1 ...) - (raise-syntax-error - #f - "Zu wenige Operanden für define-record-procedures-parametric-2" x))))) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/deinprogramm-langs.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/deinprogramm-langs.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/deinprogramm-langs.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/deinprogramm-langs.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,1280 +0,0 @@ -#lang scheme/base - -(require string-constants - framework - (prefix-in et: errortrace/stacktrace) - (prefix-in tr: trace/stacktrace) - mzlib/pretty - (prefix-in pc: mzlib/pconvert) - mzlib/file - mzlib/unit - mzlib/class - mzlib/list - racket/match - racket/path - (only-in racket/list add-between last) - racket/contract - mzlib/struct - mzlib/compile - drscheme/tool - mred - framework/private/bday - syntax/moddep - mrlib/cache-image-snip - compiler/embed - wxme/wxme - setup/dirs - setup/getinfo - setup/collects - - lang/stepper-language-interface - lang/debugger-language-interface - lang/run-teaching-program - lang/private/continuation-mark-key - lang/private/rewrite-error-message - - (only-in test-engine/scheme-gui make-formatter) - test-engine/scheme-tests - lang/private/tp-dialog - (lib "test-display.scm" "test-engine") - deinprogramm/signature/signature - lang/htdp-langs-interface - ) - - - (require mzlib/pconvert-prop) - - (require "convert-explicit.rkt") - - (require (only-in mrlib/syntax-browser render-syntax/snip)) - - (provide tool@) - - (define ellipses-cutoff 200) - - (define o (current-output-port)) - (define (oprintf . args) (apply fprintf o args)) - - (define generic-proc - (procedure-rename void '?)) - - ;; adapted from collects/drracket/private/main.rkt - (preferences:set-default 'drracket:deinprogramm:last-set-teachpacks/multi-lib - '() - (lambda (x) - (and (list? x) - (andmap (lambda (x) - (and (list? x) - (pair? x) - (eq? (car x) 'lib) - (andmap string? (cdr x)))) - x)))) - - - (define tool@ - (unit - (import drscheme:tool^) - (export drscheme:tool-exports^) - - (define drs-eventspace (current-eventspace)) - - ;; writing-style : {explicit, datum} - ;; tracing? : boolean - ;; teachpacks : (listof require-spec) - (define-struct (deinprogramm-lang-settings drscheme:language:simple-settings) - (writing-style tracing? teachpacks)) - (define deinprogramm-lang-settings->vector (make-->vector deinprogramm-lang-settings)) - (define deinprogramm-teachpacks-field-index - (+ (procedure-arity drscheme:language:simple-settings) 2)) - - (define image-string "") - - (define deinprogramm-language<%> - (interface () - get-module - get-language-position - get-sharing-printing - get-abbreviate-cons-as-list - get-allow-sharing? - get-use-function-output-syntax? - get-accept-quasiquote? - get-read-accept-dot)) - - ;; 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 printing-style writing-style super%) - (class* super% () - - (inherit get-sharing-printing get-abbreviate-cons-as-list) - - (define/override (default-settings) - (make-deinprogramm-lang-settings - #f - printing-style - 'repeating-decimal - (get-sharing-printing) - #t - 'none - writing-style - #f - (preferences:get 'drracket:deinprogramm:last-set-teachpacks/multi-lib))) - - (define/override (default-settings? s) - (and (not (drscheme:language:simple-settings-case-sensitive s)) - (eq? (drscheme:language:simple-settings-printing-style s) - printing-style) - (eq? (drscheme:language:simple-settings-fraction-style s) - 'repeating-decimal) - (eqv? (drscheme:language:simple-settings-show-sharing s) - (get-sharing-printing)) - (drscheme:language:simple-settings-insert-newlines s) - (eq? (drscheme:language:simple-settings-annotations s) - 'none) - (eq? writing-style (deinprogramm-lang-settings-writing-style s)) - (not (deinprogramm-lang-settings-tracing? s)) - (null? (deinprogramm-lang-settings-teachpacks s)))) - - (define/override (marshall-settings x) - (list (super marshall-settings x) - (deinprogramm-lang-settings-writing-style x) - (deinprogramm-lang-settings-tracing? x) - (deinprogramm-lang-settings-teachpacks x))) - - (define/override (unmarshall-settings x) - (if (and (list? x) - (= (length x) 4) - (symbol? (list-ref x 1)) ; #### - (boolean? (list-ref x 2)) - (list-of-require-specs? (list-ref x 3))) - (let ([drs-settings (super unmarshall-settings (first x))]) - (make-deinprogramm-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) - (cadddr x))) - (default-settings))) - - (define/private (list-of-require-specs? l) - (and (list? l) - (andmap (lambda (x) - (and (list? x) - (andmap (lambda (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)] - [scheme-test-module-name - ((current-module-name-resolver) '(lib "test-engine/scheme-tests.rkt") #f #f #t)] - [scheme-signature-module-name - ((current-module-name-resolver) '(lib "deinprogramm/signature/signature-german.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?)) - (ensure-drscheme-secrets-declared drs-namespace) - (namespace-attach-module drs-namespace ''drscheme-secrets) - (error-display-handler teaching-languages-error-display-handler) - - (current-eval (add-annotation (deinprogramm-lang-settings-tracing? settings) (current-eval))) - - (error-print-source-location #f) - (read-decimal-as-inexact #t) - (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? (preferences:get 'signatures:enable-checking?)) - (test-format (make-formatter (lambda (v o) - (render-value/format (if (procedure? v) - generic-proc - v) - settings o 40)))) - ))) - (super on-execute settings run-in-user-thread) - - ;; DeinProgramm addition, copied from language.rkt - (run-in-user-thread - (lambda () - (global-port-print-handler - (lambda (value port) - (let ([converted-value (simple-module-based-language-convert-value value settings)]) - (setup-printing-parameters - (lambda () - (parameterize ([pretty-print-columns 'infinity]) - (pretty-print converted-value port))) - settings - 'infinity))))))) - - ;; set-printing-parameters : settings ( -> TST) -> TST - ;; is implicitly exposed to the stepper. watch out! -- john - (define/public (set-printing-parameters settings thunk) - (parameterize ([pc:booleans-as-true/false #f] - [pc:abbreviate-cons-as-list (get-abbreviate-cons-as-list)] - [pretty-print-show-inexactness #f] - [pretty-print-exact-as-decimal #f] - [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) - (set-printing-parameters - settings - (lambda () - (simple-module-based-language-render-value/format value settings port width)))) - - (define/override (render-value value settings port) - (set-printing-parameters - settings - (lambda () - (simple-module-based-language-render-value/format value settings port 'infinity)))) - - (super-new))) - - ;; this inspector should be powerful enough to see - ;; any structure defined in the user's namespace - (define drscheme-inspector (current-inspector)) - - ;; FIXME: brittle, mimics drscheme-secrets - ;; as declared in lang/htdp-langs.rkt. - ;; Is it even needed for DeinProgramm langs? - ;; Only used by htdp/hangman teachpack. - (define (ensure-drscheme-secrets-declared drs-namespace) - (parameterize ((current-namespace drs-namespace)) - (define (declare) - (eval `(,#'module drscheme-secrets mzscheme - (provide drscheme-inspector) - (define drscheme-inspector ,drscheme-inspector))) - (namespace-require ''drscheme-secrets)) - (with-handlers ([exn:fail? (lambda (e) (declare))]) - ;; May have been declared by lang/htdp-langs tool, if loaded - (dynamic-require ''drscheme-secrets 'drscheme-inspector)) - (void))) - - - ;; { - ;; all this copied from collects/drracket/private/language.rkt - - ;; stepper-convert-value : TST settings -> TST - (define (stepper-convert-value value settings) - (define ((leave-snips-alone-hook sh) expr basic-convert sub-convert) - (if (or (is-a? expr snip%) - ;; FIXME: internal in language.rkt (to-snip-value? expr) - ) - expr - (sh expr basic-convert sub-convert))) - ;; mflatt: MINOR HACK - work around temporary - ;; print-convert problems - (define (stepper-print-convert v) - (or (and (procedure? v) (object-name v)) - (pc:print-convert v))) - - (case (drscheme:language:simple-settings-printing-style settings) - [(write) - (let ((v (convert-explicit value))) - (or (and (procedure? v) (object-name v)) - v))] - [(current-print) value] - [(constructor) - (parameterize - ([pc:constructor-style-printing #t] - [pc:show-sharing - (drscheme:language:simple-settings-show-sharing settings)] - [pc:current-print-convert-hook - (leave-snips-alone-hook (pc:current-print-convert-hook))]) - (stepper-print-convert value))] - [(quasiquote) - (parameterize - ([pc:constructor-style-printing #f] - [pc:show-sharing - (drscheme:language:simple-settings-show-sharing settings)] - [pc:current-print-convert-hook - (leave-snips-alone-hook (pc:current-print-convert-hook))]) - (stepper-print-convert value))] - [else (error "Internal stepper error: time to resync with simple-module-based-language-convert-value")])) - - ;; set-print-settings ; settings ( -> TST) -> TST - (define (set-print-settings language simple-settings thunk) - (if (method-in-interface? 'set-printing-parameters (object-interface language)) - (send language set-printing-parameters simple-settings thunk) - ;; assume that the current print-convert context is fine - ;; (error 'stepper-tool "language object does not contain set-printing-parameters method") - (thunk))) - - ;; simple-module-based-language-render-value/format : TST settings port (union #f (snip% -> void)) (union 'infinity number) -> void - (define (simple-module-based-language-render-value/format value settings port width) - (if (eq? (drscheme:language:simple-settings-printing-style settings) 'current-print) - (parameterize ([current-output-port port]) - ((current-print) value)) - (let ([converted-value (simple-module-based-language-convert-value value settings)]) - (setup-printing-parameters - (lambda () - (cond - [(drscheme:language:simple-settings-insert-newlines settings) - (if (number? width) - (parameterize ([pretty-print-columns width]) - (pretty-print converted-value port)) - (pretty-print converted-value port))] - [else - (parameterize ([pretty-print-columns 'infinity]) - (pretty-print converted-value port)) - (newline port)])) - settings - width)))) - - ;; setup-printing-parameters : (-> void) -> void - (define (setup-printing-parameters thunk settings width) - (let ([use-number-snip? - (lambda (x) - (and (number? x) - (exact? x) - (real? x) - (not (integer? x))))]) - (parameterize (;; these three handlers aren't used, but are set to override the user's settings - [pretty-print-print-line (lambda (line-number op old-line dest-columns) - (when (and (not (equal? line-number 0)) - (not (equal? dest-columns 'infinity))) - (newline op)) - 0)] - [pretty-print-pre-print-hook (lambda (val port) (void))] - [pretty-print-post-print-hook (lambda (val port) (void))] - - - [pretty-print-columns width] - [pretty-print-size-hook - (lambda (value display? port) - (cond - [(not (port-writes-special? port)) #f] - [(is-a? value snip%) 1] - [(use-number-snip? value) 1] - [(syntax? value) 1] - [(to-snip-value? value) 1] - [else #f]))] - [pretty-print-print-hook - (lambda (value display? port) - (cond - [(is-a? value snip%) - (write-special value port) - 1] - [(use-number-snip? value) - (write-special - (case (drscheme:language:simple-settings-fraction-style settings) - [(mixed-fraction) - (number-snip:make-fraction-snip value #f)] - [(mixed-fraction-e) - (number-snip:make-fraction-snip value #t)] - [(repeating-decimal) - (number-snip:make-repeating-decimal-snip value #f)] - [(repeating-decimal-e) - (number-snip:make-repeating-decimal-snip value #t)]) - port) - 1] - [(syntax? value) - (write-special (render-syntax/snip value) port)] - [else (write-special (value->snip value) port)]))] - [print-graph - ;; only turn on print-graph when using `write' printing - ;; style because the sharing is being taken care of - ;; by the print-convert sexp construction when using - ;; other printing styles. - (and (eq? (drscheme:language:simple-settings-printing-style settings) 'write) - (drscheme:language:simple-settings-show-sharing settings))]) - (thunk)))) - - ;; DeinProgramm changes in this procedure - ;; simple-module-based-language-convert-value : TST settings -> TST - (define (simple-module-based-language-convert-value value settings) - (case (drscheme:language:simple-settings-printing-style settings) - [(write) - ;; THIS IS THE CHANGE - (case (deinprogramm-lang-settings-writing-style settings) - [(explicit) (convert-explicit value)] - [(datum) value])] - [(current-print) value] - [(constructor) - (parameterize ([pc:constructor-style-printing #t] - [pc:show-sharing (drscheme:language:simple-settings-show-sharing settings)] - [pc:current-print-convert-hook (leave-snips-alone-hook (pc:current-print-convert-hook))]) - (pc:print-convert value))] - [(quasiquote) - (parameterize ([pc:constructor-style-printing #f] - [pc:show-sharing (drscheme:language:simple-settings-show-sharing settings)] - [pc:current-print-convert-hook (leave-snips-alone-hook (pc:current-print-convert-hook))]) - (pc:print-convert value))])) - - ;; leave-snips-alone-hook : any? (any? -> printable) any? -> printable - (define ((leave-snips-alone-hook sh) expr basic-convert sub-convert) - (if (is-a? expr snip%) - expr - (sh expr basic-convert sub-convert))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; snip/value extensions - ;; - - (define to-snips null) - (define-struct to-snip (predicate? >value)) - (define (add-snip-value predicate constructor) - (set! to-snips (cons (make-to-snip predicate constructor) to-snips))) - - (define (value->snip v) - (ormap (lambda (to-snip) (and ((to-snip-predicate? to-snip) v) - ((to-snip->value to-snip) v))) - to-snips)) - (define (to-snip-value? v) - (ormap (lambda (to-snip) ((to-snip-predicate? to-snip) v)) to-snips)) - - - ;; } - - ;; 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) - (let* ([parent (make-object vertical-panel% _parent)] - - [input-panel (instantiate group-box-panel% () - (parent parent) - (label (string-constant input-syntax)) - (alignment '(left center)))] - - [output-panel (instantiate group-box-panel% () - (parent parent) - (label (string-constant output-syntax)) - (alignment '(left center)))] - - [tp-group-box (instantiate group-box-panel% () - (label (string-constant teachpacks)) - (parent parent) - (alignment '(center top)))] - [tp-panel (new vertical-panel% - [parent tp-group-box] - [alignment '(center center)] - [stretchable-width #f] - [stretchable-height #f])] - - [case-sensitive (make-object check-box% - (string-constant case-sensitive-label) - input-panel - void)] - [output-style (make-object radio-box% - (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))) - output-panel - void)] - [writing-style (make-object radio-box% - "write-Ausgabe" - (list "explizit" - "Datum") - output-panel - void)] - [fraction-style - (make-object radio-box% (string-constant fraction-style) - (list (string-constant use-mixed-fractions) - (string-constant use-repeating-decimals)) - output-panel - void)] - [show-sharing #f] - [insert-newlines (make-object check-box% - (string-constant use-pretty-printer-label) - output-panel - void)] - - [tracing (new check-box% - (parent output-panel) - (label (string-constant tracing-enable-tracing)) - (callback void))] - - [tps '()]) - - (when allow-sharing-config? - (set! show-sharing - (instantiate 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) - - (case-lambda - [() - (make-deinprogramm-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 - (case (send writing-style get-selection) - [(0) 'explicit] - [(1) 'datum]) - (send tracing get-value) - tps)] - [(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] - [(write) 2] - [(print) 2]) - (case (drscheme:language:simple-settings-printing-style settings) - [(constructor) 0] - [(quasiquote) 0] - [(write) 1] - [(print) 1]))) - (send writing-style set-selection - (case (deinprogramm-lang-settings-writing-style settings) - [(explicit) 0] - [(datum) 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 (deinprogramm-lang-settings-teachpacks settings)) - (send tp-panel change-children (lambda (l) '())) - (if (null? tps) - (new message% - [parent tp-panel] - [label (string-constant teachpacks-none)]) - (for-each - (lambda (tp) (new message% - [parent tp-panel] - [label (format "~s" tp)])) - tps)) - (send tracing set-value (deinprogramm-lang-settings-tracing? settings)) - (void)]))) - - (define simple-deinprogramm-language% - ;; htdp-language<%> interface is here to make - ;; the "Racket | Disable Tests" menu item - ;; work for these languages - (class* drscheme:language:simple-module-based-language% (deinprogramm-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 #t) ;; #### should only be this in advanced mode - (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-deinprogramm-style-delta) style-delta) - - (super-instantiate () - (language-url "http://www.deinprogramm.de/dmda/")))) - - (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 (deinprogramm-lang-settings-teachpacks settings)) - - (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 " und " 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 " und " 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/private (tp-require->str tp) - (match tp - [`(lib ,x) - (define m (regexp-match #rx"teachpack/deinprogramm/(.*)$" x)) - (if m - (list-ref m 1) - (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 - (lambda (exe-name) - (create-embedding-executable - exe-name - #:modules `((#f ,program-filename)) - #:cmdline `("-l" - "scheme/base" - "-e" - ,(format "~s" `(#%require ',(filename->require-symbol program-filename)))) - #:src-filter - (lambda (path) (cannot-compile? path)) - #:get-extra-imports - (lambda (path cm) - (call-with-input-file path - (lambda (port) - (cond - [(is-wxme-stream? port) - (let-values ([(snip-class-names data-class-names) - (extract-used-classes port)]) - (list* - '(lib "wxme/read.ss") - '(lib "mred/mred.ss") - reader-module - (filter - values - (map (lambda (x) (string->lib-path x #t)) - (append - snip-class-names - data-class-names)))))] - [else - '()])))) - #:mred? #t)))))) - - (define/private (filename->require-symbol fn) - (let-values ([(base name dir) (split-path fn)]) - (string->symbol - (path->string - (path-replace-suffix name #""))))) - - (define/private (symbol-append x y) - (string->symbol - (string-append - (symbol->string x) - (symbol->string y)))) - - (inherit get-deinprogramm-style-delta) - (define/override (get-style-delta) - (get-deinprogramm-style-delta)) - - (inherit get-reader set-printing-parameters) - - (define/override (front-end/complete-program port settings) - (expand-teaching-program port - (get-reader) - (get-module) - (deinprogramm-lang-settings-teachpacks settings) - '#%deinprogramm)) - - (define/override (front-end/interaction port settings) - (let ([reader (get-reader)] ;; DeinProgramm addition: - ;; needed for test boxes; see - ;; the code in - ;; collects/drracket/private/language.rkt - [start? #t] - [done? #f]) - (λ () - (cond - [start? - (set! start? #f) - #'(#%plain-app reset-tests)] - [done? eof] - [else - (let ([ans (reader (object-name port) port)]) - (cond - [(eof-object? ans) - (set! done? #t) - #`(test)] - [else - ans]))])))) - - (define/augment (capability-value key) - (case key - [(drscheme:teachpack-menu-items) deinprogramm-teachpack-callbacks] - [(drscheme:special:insert-lambda) #f] - [else (inner (drscheme:language:get-capability-default key) - capability-value - key)])) - - (define deinprogramm-teachpack-callbacks - (drscheme:unit:make-teachpack-callbacks - (lambda (settings) - (map (lambda (x) (tp-require->str x)) (deinprogramm-lang-settings-teachpacks settings))) - (lambda (settings parent) - (define old-tps (deinprogramm-lang-settings-teachpacks settings)) - (define tp-dirs (list "deinprogramm")) - (define labels (list (string-constant teachpack-pre-installed))) - (define tp-syms '(deinprogramm-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))))) - - (preferences:set 'drracket:deinprogramm:last-set-teachpacks/multi-lib new-tps) - (make-deinprogramm-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) - (deinprogramm-lang-settings-writing-style settings) - (deinprogramm-lang-settings-tracing? settings) - new-tps)) - (lambda (settings name) - (let ([new-tps (filter (lambda (x) (not (equal? (tp-require->str x) name))) - (deinprogramm-lang-settings-teachpacks settings))]) - (preferences:set 'drracket:deinprogramm:last-set-teachpacks/multi-lib new-tps) - (make-deinprogramm-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) - (deinprogramm-lang-settings-writing-style settings) - (deinprogramm-lang-settings-tracing? settings) - new-tps))) - (lambda (settings) - (preferences:set 'drracket:deinprogramm:last-set-teachpacks/multi-lib '()) - (make-deinprogramm-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) - (deinprogramm-lang-settings-writing-style settings) - (deinprogramm-lang-settings-tracing? settings) - '())))) - - (inherit-field reader-module) - (define/override (get-reader-module) reader-module) - (define/override (get-metadata modname settings) - (define parsed-tps - (marshall-teachpack-settings - (deinprogramm-lang-settings-teachpacks settings))) - (string-append - ";; Die ersten drei Zeilen dieser Datei wurden von DrRacket eingefügt. Sie enthalten Metadaten\n" - ";; über die Sprachebene dieser Datei in einer Form, die DrRacket verarbeiten kann.\n" - (format "#reader~s~s\n" - reader-module - `((modname ,modname) - (read-case-sensitive ,(drscheme:language:simple-settings-case-sensitive settings)) - (teachpacks ,parsed-tps) - (deinprogramm-settings - ,(for/vector ([e (in-vector (deinprogramm-lang-settings->vector settings))] - [i (in-naturals)]) - (cond - [(= i deinprogramm-teachpacks-field-index) parsed-tps] - [else e]))))))) - - (inherit default-settings) - (define/override (metadata->settings metadata) - (let* ([table (metadata->table metadata)] ;; extract the table - [ssv (assoc 'deinprogramm-settings table)]) - (if ssv - (let ([settings-list (vector->list (cadr ssv))]) - (if (equal? (length settings-list) - (procedure-arity make-deinprogramm-lang-settings)) - (apply make-deinprogramm-lang-settings - (for/list ([i (in-naturals)] - [e (in-list settings-list)]) - (cond - [(= i deinprogramm-teachpacks-field-index) - (unmarshall-teachpack-settings e)] - [else e]))) - (default-settings))) - (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 (metadata->table metadata) - (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))) - - ;; cannot-compile? : path -> boolean - ;; returns #t if the file cannot be compiled, #f otherwise - (define (cannot-compile? path) - (call-with-input-file path - (lambda (port) - (let ([ok-to-compile-names - (map (lambda (x) (format "~s" x)) - '(wxtext - (lib "comment-snip.ss" "framework") - (lib "xml-snipclass.ss" "xml") - (lib "scheme-snipclass.ss" "xml") - (lib "test-case-box-snipclass.ss" "test-suite")))]) - (and (is-wxme-stream? port) - (let-values ([(snip-class-names data-class-names) - (extract-used-classes port)]) - (not (and (andmap - (lambda (used-name) (member used-name ok-to-compile-names)) - snip-class-names) - (andmap - (lambda (used-name) (member used-name ok-to-compile-names)) - data-class-names))))))))) - - (define (stepper-settings-language %) - (if (implementation? % stepper-language<%>) - (class* % (stepper-language<%>) - (init-field stepper:supported) - (define/override (stepper:supported?) stepper:supported) - (define/override (stepper:show-inexactness?) #f) - (define/override (stepper:print-boolean-long-form?) #f) - (define/override (stepper:show-consumed-and/or-clauses?) #f) - (define/override (stepper:render-to-sexp val settings language-level) - (parameterize ([pc:current-print-convert-hook (make-print-convert-hook settings)]) - (set-print-settings - language-level - settings - (lambda () - (stepper-convert-value val settings))))) - (super-new)) - (class % - (init stepper:supported) - (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)))) - - ;; make-print-convert-hook: - ;; simple-settings -> (TST (TST -> TST) (TST -> TST) -> TST) - ;; this code copied from various locations in language.rkt and rep.rkt - (define (make-print-convert-hook simple-settings) - (lambda (exp basic-convert sub-convert) - (cond - [(is-a? exp snip%) - (send exp copy)] - [else (basic-convert exp)]))) - - ;; 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))) - - - ; - ; - ; - ; - ; - ; ; - ; ;;; ; ; ; ; ;;; ; ; ;;;; ; ; ;;; ;;; ;;; - ; ; ; ;; ;; ; ; ;; ; ;; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ;;;;;; ; ; ; ; ; ; ; ;;;; ; ;;;;;; - ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ;;;; ; ; ;;; ; ;; ; ;;;;; ;;; ;;;; - ; - ; - ; - - (define mf-note - (let ([bitmap - (make-object bitmap% - (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)) - (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)) - - (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 (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) - (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 - ;; - - ;; WARNING: much code copied from "collects/lang/htdp-langs.rkt" - - (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 - (lambda () - (let ([on-sd (make-object style-delta%)] - [off-sd (make-object style-delta%)]) - (cond - [(preferences:get 'framework:white-on-black?) - (send on-sd set-delta-foreground "white") - (send off-sd set-delta-background "lightblue") - (send off-sd set-delta-foreground "black")] - [else - (send on-sd set-delta-foreground "black") - (send off-sd set-delta-background "lightblue") - (send off-sd set-delta-foreground "black")]) - (send rep set-test-coverage-info ht on-sd off-sd #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 'deinprogramm-langs - "internal-error: no test-coverage table"))] - [v (hash-ref ht expr - (lambda () - (error 'deinprogramm-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^))) - - ;; 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-deinprogramm-language : (instanceof deinprogramm-language<%>) -> void - (define (add-deinprogramm-language o) - (drscheme:language-configuration:add-language - o - #:allow-executable-creation? #t)) - - (define (phase1) (void)) - - ;; phase2 : -> void - (define (phase2) - (define (make-deinprogramm-language% printing-style writing-style) - (debugger-settings-language - (stepper-settings-language - ((drscheme:language:get-default-mixin) - (language-extension - (drscheme:language:module-based-language->language-mixin - (module-based-language-extension - printing-style writing-style - (drscheme:language:simple-module-based-language->module-based-language-mixin - simple-deinprogramm-language%)))))))) - - (add-deinprogramm-language - (instantiate (make-deinprogramm-language% 'write 'explicit) () - (module '(lib "deinprogramm/DMdA-beginner.rkt")) - (manual #"DMdA-beginner") - (language-position (list (string-constant teaching-languages) - "DeinProgramm" "Die Macht der Abstraktion - Anfänger")) - (language-id "DMdA:beginner") - (language-numbers '(-500 -300 3)) - (sharing-printing #f) - (abbreviate-cons-as-list #t) - (allow-sharing? #f) - (reader-module '(lib "DMdA-beginner-reader.ss" "deinprogramm")) - (stepper:supported #t))) - - (add-deinprogramm-language - (instantiate (make-deinprogramm-language% 'write 'explicit) () - (module '(lib "deinprogramm/DMdA-vanilla.rkt")) - (manual #"DMdA-vanilla") - (language-position (list (string-constant teaching-languages) - "DeinProgramm" "Die Macht der Abstraktion")) - (language-id "DMdA:vanilla") - (language-numbers '(-500 -300 4)) - (sharing-printing #f) - (abbreviate-cons-as-list #t) - (allow-sharing? #f) - (reader-module '(lib "DMdA-vanilla-reader.ss" "deinprogramm")) - (stepper:supported #t))) - - (add-deinprogramm-language - (instantiate (make-deinprogramm-language% 'write 'explicit) () - (module '(lib "deinprogramm/DMdA-assignments.rkt")) - (manual #"DMdA-assignments") - (language-position (list (string-constant teaching-languages) - "DeinProgramm" "Die Macht der Abstraktion mit Zuweisungen")) - (language-id "DMdA:assignments") - (language-numbers '(-500 -300 5)) - (sharing-printing #t) - (abbreviate-cons-as-list #t) - (allow-sharing? #t) - (reader-module '(lib "DMdA-assignments-reader.ss" "deinprogramm")) - (stepper:supported #f) - (debugger:supported #t))) - - (add-deinprogramm-language - (instantiate (make-deinprogramm-language% 'write 'datum) () - (module '(lib "deinprogramm/DMdA-advanced.rkt")) - (manual #"DMdA-advanced") - (language-position (list (string-constant teaching-languages) - "DeinProgramm" "Die Macht der Abstraktion - fortgeschritten")) - (language-id "DMdA:advanced") - (language-numbers '(-500 -300 6)) - (sharing-printing #t) - (abbreviate-cons-as-list #t) - (allow-sharing? #t) - (reader-module '(lib "DMdA-advanced-reader.ss" "deinprogramm")) - (stepper:supported #f) - (debugger:supported #t)))))) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/define-record-procedures.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/define-record-procedures.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/define-record-procedures.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/define-record-procedures.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,25 @@ +#lang scheme/base + +(provide define-record-procedures + define-record-procedures-parametric + define-record-procedures-2 + define-record-procedures-parametric-2) + +(require scheme/include + scheme/promise + mzlib/struct + mzlib/pconvert-prop + mzlib/pretty + deinprogramm/signature/signature + deinprogramm/signature/signature-german + deinprogramm/signature/signature-syntax + (only-in deinprogramm/quickcheck/quickcheck arbitrary-record arbitrary-one-of)) + +(require deinprogramm/private/explicit-write) + +(require (for-syntax scheme/base) + (for-syntax deinprogramm/private/syntax-checkers) + (for-syntax stepper/private/syntax-property) + (for-syntax racket/struct-info) + (for-syntax syntax/struct)) +(include "define-record-procedures.scm") diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/define-record-procedures.scm racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/define-record-procedures.scm --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/define-record-procedures.scm 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/define-record-procedures.scm 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,648 @@ +(define any (signature any %any)) + +(define-syntax define-record-procedures* + + (let () + (define (filter-map proc l) + (if (null? l) + '() + (let ((result (proc (car l)))) + (if result + (cons result (filter-map proc (cdr l))) + (filter-map proc (cdr l)))))) + + + (define (syntax-member? thing stuff) + (cond + ((null? stuff) #f) + ((free-identifier=? thing (car stuff)) #t) + (else (syntax-member? thing (cdr stuff))))) + + (define (map-with-index proc list) + (let loop ((i 0) (list list) (rev-result '())) + (if (null? list) + (reverse rev-result) + (loop (+ 1 i) + (cdr list) + (cons (proc i (car list)) rev-result))))) + + (lambda (x) + (syntax-case x () + ((_ ?stx + ?type-spec + ?mutable? + ?signature-constructor-name + ?constructor + ?predicate + (?field-spec ...)) + + (with-syntax + (((?type-name ?type-params ...) + (if (identifier? #'?type-spec) + #'(?type-spec) + #'?type-spec)) + (number-of-fields (length (syntax->list (syntax (?field-spec ...))))) + ((accessor ...) + (map (lambda (field-spec) + (syntax-case field-spec () + ((accessor mutator signature) #'accessor))) + (syntax->list (syntax (?field-spec ...))))) + ((mutator ...) + (map (lambda (field-spec) + (syntax-case field-spec () + ((accessor mutator signature) #'mutator))) + (syntax->list (syntax (?field-spec ...)))))) + (let ((maybe-field-signatures + (map (lambda (field-spec) + (syntax-case field-spec () + ((accessor mutator #f) #f) + ((accessor mutator sig) #'sig))) + (syntax->list (syntax (?field-spec ...)))))) + (with-syntax + (((field-signature ...) + (map (lambda (sig) (or sig #'any)) maybe-field-signatures)) + ((accessor-proc ...) + (map-with-index + (lambda (i accessor) + (with-syntax ((i i) + (tag accessor)) + (syntax-property (syntax/loc + accessor + (lambda (s) + (when (not (raw-predicate s)) + (raise + (make-exn:fail:contract + (string->immutable-string + (format "~a: Argument kein ~a: ~e" + 'tag '?type-name s)) + (current-continuation-marks)))) + (raw-generic-access s i))) + 'inferred-name + (syntax-e accessor)))) + (syntax->list #'(accessor ...)))) + ((our-accessor ...) (generate-temporaries #'(accessor ...))) + (real-constructor + ;; use a different name for the value binding, but + ;; make sure the stepper prints the one from the d-r-p form + (let ((name #`?constructor)) + (stepper-syntax-property + (datum->syntax + #f + (string->uninterned-symbol + (symbol->string (syntax-e name)))) + 'stepper-orig-name + name))) + ((mutator-proc ...) + (map-with-index + (lambda (i mutator) + (with-syntax ((i i) + (tag mutator)) + (syntax-property (syntax/loc + mutator + (lambda (s v) + (when (not (raw-predicate s)) + (raise + (make-exn:fail:contract + (string->immutable-string + (format "~a: Argument kein ~a: ~e" + 'tag '?type-name s)) + (current-continuation-marks)))) + (raw-generic-mutate s i v))) + 'inferred-name + (syntax-e mutator)))) + (syntax->list #'(mutator ...)))) + (constructor-proc + (syntax-property #'(lambda (accessor ...) + (raw-constructor accessor ... #f)) + 'inferred-name + (syntax-e #'?constructor))) + (predicate-proc + (syntax-property #'(lambda (thing) + (raw-predicate thing)) + 'inferred-name + (syntax-e #'?predicate))) + ((raw-accessor-proc ...) + (map-with-index (lambda (i _) + #`(lambda (r) + (raw-generic-access r #,i))) + (syntax->list #'(?field-spec ...)))) + ((raw-mutator-proc ...) + (map-with-index (lambda (i _) + #`(lambda (r val) + (raw-generic-mutate r #,i val))) + (syntax->list #'(?field-spec ...)))) + + (record-equal? #`(lambda (r1 r2 equal?) + (and #,@(map-with-index (lambda (i field-spec) + #`(equal? (raw-generic-access r1 #,i) + (raw-generic-access r2 #,i))) + (syntax->list #'(?field-spec ...)))))) + ((?type-param-bindings ...) + (map (lambda (type-param) + (with-syntax ((?type-param type-param) + (?type-var (string->symbol + (string-append "%" (symbol->string (syntax->datum type-param)))))) + #'(?type-param (signature ?type-var)))) + (syntax->list #'(?type-params ...))))) + + + (with-syntax + ((struct-type-defs + #'(define-values (type-descriptor + raw-constructor + raw-predicate + raw-generic-access + raw-generic-mutate) + (make-struct-type + '?type-name #f (+ 1 number-of-fields) 0 + #f + (list + (cons prop:print-convert-constructor-name + '?constructor) + (cons prop:custom-write + (make-constructor-style-printer + (lambda (obj) + (string->symbol (string-append "record:" (symbol->string '?type-name)))) + (lambda (obj) + (access-record-fields obj raw-generic-access number-of-fields)))) + (cons prop:print-converter + (lambda (r recur) + (list '?constructor + (recur (raw-accessor-proc r)) ...))) + (cons prop:equal+hash + (list record-equal? + (make-equal-hash (lambda (r i) (raw-generic-access r i)) number-of-fields) + (make-equal2-hash (lambda (r i) (raw-generic-access r i)) number-of-fields))) + (cons prop:lazy-wrap + (make-lazy-wrap-info constructor-proc + (list raw-accessor-proc ...) + (list raw-mutator-proc ...) + (lambda (r) + (raw-generic-access r number-of-fields)) + (lambda (r val) + (raw-generic-mutate r number-of-fields val))))) + (make-inspector)))) + (real-constructor-def + #'(define/signature real-constructor + (let (?type-param-bindings ...) + (signature (field-signature ... -> ?type-spec))) + constructor-proc)) + (constructor-def #'(define-syntax ?constructor + (let () + (define-struct info () + #:super struct:struct-info + ;; support `signature' + #:property + prop:procedure + (lambda (_ stx) + (syntax-case stx () + [(self . args) (syntax/loc stx (real-constructor . args))] + [else (syntax/loc stx real-constructor)]))) + (make-info (lambda () + (list #f + #'real-constructor + #'real-predicate + (reverse (syntax->list #'(our-accessor ...))) + (map (lambda (_) #f) (syntax->list #'(our-accessor ...))) + #f)))))) + (predicate-def #'(define-values (?predicate real-predicate) + (values predicate-proc predicate-proc))) + (accessor-defs #'(define-values (accessor ... our-accessor ...) + (values accessor-proc ... accessor-proc ...))) + (mutator-defs #'(define-values (mutator ...) (values mutator-proc ...))) + (signature-def + (with-syntax (((?param ...) (generate-temporaries #'(?field-spec ...)))) + (with-syntax (((component-signature ...) + (map (lambda (accessor param) + (with-syntax ((?accessor accessor) + (?param param)) + #'(at ?param (property ?accessor ?param)))) + (syntax->list #'(our-accessor ...)) + (syntax->list #'(?param ...))))) + (with-syntax ((base-signature + (stepper-syntax-property + #`(define ?type-spec + #,(cond + ((null? maybe-field-signatures) + #'(let ((sig (signature ?type-name (predicate real-predicate)))) + (set-signature-arbitrary-promise! + sig + (delay (arbitrary-one-of equal? (real-constructor)))) + sig)) + ((andmap values maybe-field-signatures) ; monomorphic + #'(let* ((sigs (list (signature field-signature) ...)) + (sig + (make-lazy-wrap-signature '?type-name #t + type-descriptor raw-predicate + sigs + #'?type-name))) + (set-signature-arbitrary-promise! + sig + (delay + (let ((arbs (map signature-arbitrary sigs))) + (when (andmap values arbs) + (apply arbitrary-record + real-constructor + (list raw-accessor-proc ...) + arbs))))) + sig)) + (else + #'(signature ?type-name (predicate real-predicate))))) + 'stepper-skip-completely + #t)) + (constructor-signature + (stepper-syntax-property + (if (syntax->datum #'?mutable?) + ;; no lazy signatures + #'(define (?signature-constructor-name ?param ...) + (signature + (combined (at ?type-name (predicate real-predicate)) + component-signature ...))) + ;; lazy signatures + #'(define (?signature-constructor-name ?param ...) + (let* ((sigs (list ?param ...)) + (sig + (make-lazy-wrap-signature '?type-name #t + type-descriptor raw-predicate + sigs + #'?type-name))) + (set-signature-arbitrary-promise! + sig + (delay + (let ((arbs (map signature-arbitrary sigs))) + (when (andmap values arbs) + (apply arbitrary-record + real-constructor + (list raw-accessor-proc ...) + arbs))))) + sig))) + 'stepper-skip-completely + #t))) + #'(begin + ;; we use real-predicate to avoid infinite recursion if a signature + ;; for ?type-name using ?predicate is inadvertently defined + base-signature + constructor-signature)))))) + ;; again, with properties + (with-syntax ((struct-type-defs + (stepper-syntax-property + (syntax/loc x struct-type-defs) 'stepper-black-box-expr #'?stx)) + (real-constructor-def + (stepper-syntax-property #'real-constructor-def 'stepper-skip-completely #t)) + (predicate-def + (stepper-syntax-property #'predicate-def 'stepper-skip-completely #t)) + (accessor-defs + (stepper-syntax-property #'accessor-defs 'stepper-skip-completely #t)) + (mutator-defs + (stepper-syntax-property #'mutator-defs 'stepper-skip-completely #t))) + #'(begin + struct-type-defs + signature-def + ;; the signature might be used in the definitions, hence this ordering + predicate-def real-constructor-def constructor-def accessor-defs mutator-defs))))))) + ((_ ?type-name + ?signature-constructor-name + ?constructor + ?predicate + rest) + (raise-syntax-error + #f + "Der vierte Operand ist illegal" (syntax rest))) + ((_ ?type-name + ?signature-constructor-name + ?constructor + ?predicate + rest1 rest2 ... (?field-spec ...)) + (raise-syntax-error + #f + "Vor den Selektoren/Mutatoren steht eine Form zuviel" #'rest1)) + ((_ ?type-name + ?signature-constructor-name + ?constructor + ?predicate + rest1 rest2 ...) + (raise-syntax-error + #f + "Zu viele Operanden für define-record-procedures*" x)) + ((_ arg1 ...) + (raise-syntax-error + #f + "Zu wenige Operanden für define-record-procedures*" x)))))) + +(define (access-record-fields rec acc count) + (let recur ((i 0)) + (if (= i count) + '() + (cons (acc rec i) + (recur (+ i 1)))))) + +(define (make-equal-hash generic-access field-count) + (lambda (r recur) + (let loop ((i 0) + (factor 1) + (hash 0)) + (if (= i field-count) + hash + (loop (+ 1 i) + (* factor 33) + (+ hash (* factor (recur (generic-access r i))))))))) + +(define (make-equal2-hash generic-access field-count) + (lambda (r recur) + (let loop ((i 0) + (factor 1) + (hash 0)) + (if (= i field-count) + hash + (loop (+ 1 i) + (* factor 33) + (+ hash (* factor + (recur (generic-access r (- field-count i 1)))))))))) + +;; (define-record-procedures :pare kons pare? (kar kdr)) + +(define-syntax define-record-procedures + (lambda (x) + (syntax-case x () + ((_ ?type-spec + ?constructor + (?field-spec ...)) + (syntax + (define-record-procedures ?type-spec ?constructor dummy-predicate (?field-spec ...)))) + + ((_ ?type-spec + ?constructor + ?predicate + (?field-spec ...)) + + (with-syntax (((?type-name ?type-params ...) + (if (identifier? #'?type-spec) + #'(?type-spec) + #'?type-spec))) + (check-for-id! + (syntax ?type-name) + "Typ-Name ist kein Bezeichner") + + (for-each (lambda (type-param) + (check-for-id! + type-param + "Parameter zu Typ-Konstruktor ist kein Bezeichner")) + (syntax->list #'(?type-params ...))) + + (check-for-id! + (syntax ?constructor) + "Konstruktor ist kein Bezeichner") + + (check-for-id! + (syntax ?predicate) + "Prädikat ist kein Bezeichner") + + (with-syntax ((?stx x) + (field-specs + (map + (lambda (field-spec dummy-mutator) + (syntax-case field-spec () + ((accessor signature) + (begin + (check-for-id! (syntax accessor) + "Selektor ist kein Bezeichner") + #`(accessor #,dummy-mutator signature))) + (accessor + (begin + (check-for-id! (syntax accessor) + "Selektor ist kein Bezeichner") + #`(accessor #,dummy-mutator #f))))) + (syntax->list #'(?field-spec ...)) + (generate-temporaries #'(?field-spec ...))))) + (syntax + (define-record-procedures* ?stx ?type-spec #f + dummy-signature-constructor-name + ?constructor + ?predicate + field-specs))))) + + ((_ ?type-spec + ?constructor + ?predicate + rest) + (raise-syntax-error + #f + "Der vierte Operand ist keine Liste von Selektoren" (syntax rest))) + ((_ ?type-spec + ?constructor + ?predicate + rest1 rest2 ... (accessor ...)) + (raise-syntax-error + #f + "Vor den Selektoren steht eine Form zuviel" #'rest1)) + ((_ ?type-spec + ?constructor + ?predicate + rest1 rest2 ...) + (raise-syntax-error + #f + "Zu viele Operanden für define-record-procedures" x)) + ((_ arg1 ...) + (raise-syntax-error + #f + "Zu wenige Operanden für define-record-procedures" x)) + ))) + +(define-syntax define-record-procedures-parametric + (lambda (x) + (syntax-case x () + ((_ ?type-name + ?signature-constructor-name + ?constructor + ?predicate + (accessor ...)) + + + (begin + (check-for-id! + (syntax ?type-name) + "Record-Name ist kein Bezeichner") + + (check-for-id! + (syntax ?signature-constructor-name) + "Signaturkonstruktor-Name ist kein Bezeichner") + + (check-for-id! + (syntax ?constructor) + "Konstruktor ist kein Bezeichner") + + (check-for-id! + (syntax ?predicate) + "Prädikat ist kein Bezeichner") + + (check-for-id-list! + (syntax->list (syntax (accessor ...))) + "Selektor ist kein Bezeichner") + + (with-syntax ((?stx x) + ((dummy-mutator ...) + (generate-temporaries (syntax (accessor ...))))) + (syntax + (define-record-procedures* ?stx ?type-name #f ?signature-constructor-name + ?constructor + ?predicate + ((accessor dummy-mutator #f) ...)))))) + + ((_ ?type-name + ?signature-constructor-name + ?constructor + ?predicate + rest) + (raise-syntax-error + #f + "Der vierte Operand ist keine Liste von Selektoren" (syntax rest))) + ((_ ?type-name + ?signature-constructor-name + ?constructor + ?predicate + rest1 rest2 ...) + (raise-syntax-error + #f + "Zu viele Operanden für define-record-procedures-parametric" x)) + ((_ arg1 ...) + (raise-syntax-error + #f + "Zu wenige Operanden für define-record-procedures-parametric" x)) + ))) + +;; (define-record-procedures-2 :pare kons pare? ((kar set-kar!) kdr)) + +(define-syntax define-record-procedures-2 + (lambda (x) + (syntax-case x () + ((_ ?type-name + ?constructor + ?predicate + (?field-spec ...)) + + (begin + (check-for-id! + (syntax ?type-name) + "Record-Name ist kein Bezeichner") + + (check-for-id! + (syntax ?constructor) + "Konstruktor ist kein Bezeichner") + + (check-for-id! + (syntax ?predicate) + "Prädikat ist kein Bezeichner") + + (with-syntax ((?stx x) + (field-specs + (map + (lambda (field-spec dummy-mutator) + (syntax-case field-spec () + ((accessor mutator signature) + (begin + (check-for-id! (syntax accessor) + "Selektor ist kein Bezeichner") + #'(accessor mutator signature))) + ((accessor mutator) + (begin + (check-for-id! (syntax accessor) + "Selektor ist kein Bezeichner") + #'(accessor mutator #f))) + (accessor + (begin + (check-for-id! (syntax accessor) + "Selektor ist kein Bezeichner") + #`(accessor #,dummy-mutator #f))))) + (syntax->list #'(?field-spec ...)) + (generate-temporaries #'(?field-spec ...))))) + #'(define-record-procedures* ?stx ?type-name #t + dummy-signature-constructor-name + ?constructor + ?predicate + field-specs)))) + ((_ ?type-name + ?constructor + ?predicate + rest) + (raise-syntax-error + #f + "Der vierte Operand ist illegal" (syntax rest))) + ((_ ?type-name + ?constructor + ?predicate + rest1 rest2 ...) + (raise-syntax-error + #f + "Zu viele Operanden für define-record-procedures-2" x)) + ((_ arg1 ...) + (raise-syntax-error + #f + "Zu wenige Operanden für define-record-procedures-2" x))))) + +(define-syntax define-record-procedures-parametric-2 + (lambda (x) + (syntax-case x () + ((_ ?type-name + ?signature-constructor-name + ?constructor + ?predicate + (?field-spec ...)) + + (begin + (check-for-id! + (syntax ?type-name) + "Record-Name ist kein Bezeichner") + + (check-for-id! + (syntax ?signature-constructor-name) + "Signaturkonstruktor-Name ist kein Bezeichner") + + (check-for-id! + (syntax ?constructor) + "Konstruktor ist kein Bezeichner") + + (check-for-id! + (syntax ?predicate) + "Prädikat ist kein Bezeichner") + + (with-syntax ((?stx x) + (field-specs + (map + (lambda (field-spec dummy-mutator) + (syntax-case field-spec () + ((accessor mutator) + (begin + (check-for-id! (syntax accessor) + "Selektor ist kein Bezeichner") + #'(accessor mutator #f))) + (accessor + (begin + (check-for-id! (syntax accessor) + "Selektor ist kein Bezeichner") + #`(accessor #,dummy-mutator #f))))) + (syntax->list #'(?field-spec ...)) + (generate-temporaries #'(?field-spec ...))))) + #'(define-record-procedures* ?stx ?type-name #t ?signature-constructor-name + ?constructor + ?predicate + field-specs)))) + ((_ ?type-name + ?signature-constructor-name + ?constructor + ?predicate + rest) + (raise-syntax-error + #f + "Der vierte Operand ist illegal" (syntax rest))) + ((_ ?type-name + ?signature-constructor-name + ?constructor + ?predicate + rest1 rest2 ...) + (raise-syntax-error + #f + "Zu viele Operanden für define-record-procedures-parametric-2" x)) + ((_ arg1 ...) + (raise-syntax-error + #f + "Zu wenige Operanden für define-record-procedures-parametric-2" x))))) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/lang/reader.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/lang/reader.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/lang/reader.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/lang/reader.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1,2 +1,2 @@ #lang s-exp syntax/module-reader -deinprogramm/DMdA +deinprogramm/DMdA/private/primitives diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/private/convert-explicit.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/private/convert-explicit.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/private/convert-explicit.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/private/convert-explicit.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,12 @@ +#lang scheme/base +(provide convert-explicit) + +(require mzlib/pretty + mzlib/struct) + +(require deinprogramm/private/explicit-write) + +(require deinprogramm/signature/signature-german) + +(require scheme/include) +(include "convert-explicit.scm") diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/private/convert-explicit.scm racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/private/convert-explicit.scm --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/private/convert-explicit.scm 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/private/convert-explicit.scm 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,47 @@ +; I HATE DEFINE-STRUCT! +(define-struct/properties :empty-list () + ((prop:custom-write + (lambda (r port write?) + (write-string "#" port)))) + (make-inspector)) + +;; might be improper +(define-struct/properties :list (elements) + ((prop:custom-write (make-constructor-style-printer + (lambda (obj) 'list) + (lambda (obj) (:list-elements obj))))) + (make-inspector)) + +(define (convert-explicit v) + (let ((hash (make-hasheq))) + (let recur ((v v)) + (cond + ((null? v) (make-:empty-list)) ; prevent silly printing of sharing + ((pair? v) + (make-:list + (let list-recur ((v v)) + (cond + ((null? v) + v) + ((not (pair? v)) + '()) ; the stepper feeds all kinds of garbage in here + (else + (cons (recur (car v)) + (list-recur (cdr v)))))))) + ((struct? v) + (or (hash-ref hash v #f) + (let-values (((ty skipped?) (struct-info v))) + (cond + ((and ty (lazy-wrap? ty)) + (let ((lazy-wrap-info (lazy-wrap-ref ty))) + (let ((constructor (lazy-wrap-info-constructor lazy-wrap-info)) + (raw-accessors (lazy-wrap-info-raw-accessors lazy-wrap-info))) + (let ((val (apply constructor (map (lambda (raw-accessor) + (recur (raw-accessor v))) + raw-accessors)))) + (hash-set! hash v val) + val)))) + (else v))))) + (else + v))))) + diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/private/DMdA-langs.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/private/DMdA-langs.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/private/DMdA-langs.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/private/DMdA-langs.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,1288 @@ +#lang scheme/base + +(require string-constants + framework + (prefix-in et: errortrace/stacktrace) + (prefix-in tr: trace/stacktrace) + mzlib/pretty + (prefix-in pc: mzlib/pconvert) + mzlib/file + mzlib/unit + mzlib/class + mzlib/list + racket/match + racket/path + (only-in racket/list add-between last) + racket/contract + mzlib/struct + mzlib/compile + drscheme/tool + mred + framework/private/bday + syntax/moddep + mrlib/cache-image-snip + compiler/embed + wxme/wxme + setup/dirs + setup/getinfo + setup/collects + + lang/stepper-language-interface + lang/debugger-language-interface + lang/run-teaching-program + lang/private/continuation-mark-key + lang/private/rewrite-error-message + + (only-in test-engine/scheme-gui make-formatter) + test-engine/scheme-tests + lang/private/tp-dialog + (lib "test-display.scm" "test-engine") + deinprogramm/signature/signature + lang/htdp-langs-interface + ) + + + (require mzlib/pconvert-prop) + + (require deinprogramm/DMdA/private/convert-explicit) + + (require (only-in mrlib/syntax-browser render-syntax/snip)) + + (provide tool@) + + (define ellipses-cutoff 200) + + (define o (current-output-port)) + (define (oprintf . args) (apply fprintf o args)) + + (define generic-proc + (procedure-rename void '?)) + + ;; adapted from collects/drracket/private/main.rkt + (preferences:set-default 'drracket:deinprogramm:last-set-teachpacks/multi-lib + '() + (lambda (x) + (and (list? x) + (andmap (lambda (x) + (and (list? x) + (pair? x) + (eq? (car x) 'lib) + (andmap string? (cdr x)))) + x)))) + + + (define tool@ + (unit + (import drscheme:tool^) + (export drscheme:tool-exports^) + + (define drs-eventspace (current-eventspace)) + + ;; writing-style : {explicit, datum} + ;; tracing? : boolean + ;; teachpacks : (listof require-spec) + (define-struct (deinprogramm-lang-settings drscheme:language:simple-settings) + (writing-style tracing? teachpacks)) + (define deinprogramm-lang-settings->vector (make-->vector deinprogramm-lang-settings)) + (define deinprogramm-teachpacks-field-index + (+ (procedure-arity drscheme:language:simple-settings) 2)) + + (define image-string "") + + (define deinprogramm-language<%> + (interface () + get-module + get-language-position + get-sharing-printing + get-abbreviate-cons-as-list + get-allow-sharing? + get-use-function-output-syntax? + get-accept-quasiquote? + get-read-accept-dot)) + + ;; 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 printing-style writing-style super%) + (class* super% () + + (inherit get-sharing-printing get-abbreviate-cons-as-list) + + (define/override (default-settings) + (make-deinprogramm-lang-settings + #f + printing-style + 'repeating-decimal + (get-sharing-printing) + #t + 'none + writing-style + #f + (preferences:get 'drracket:deinprogramm:last-set-teachpacks/multi-lib))) + + (define/override (default-settings? s) + (and (not (drscheme:language:simple-settings-case-sensitive s)) + (eq? (drscheme:language:simple-settings-printing-style s) + printing-style) + (eq? (drscheme:language:simple-settings-fraction-style s) + 'repeating-decimal) + (eqv? (drscheme:language:simple-settings-show-sharing s) + (get-sharing-printing)) + (drscheme:language:simple-settings-insert-newlines s) + (eq? (drscheme:language:simple-settings-annotations s) + 'none) + (eq? writing-style (deinprogramm-lang-settings-writing-style s)) + (not (deinprogramm-lang-settings-tracing? s)) + (null? (deinprogramm-lang-settings-teachpacks s)))) + + (define/override (marshall-settings x) + (list (super marshall-settings x) + (deinprogramm-lang-settings-writing-style x) + (deinprogramm-lang-settings-tracing? x) + (deinprogramm-lang-settings-teachpacks x))) + + (define/override (unmarshall-settings x) + (if (and (list? x) + (= (length x) 4) + (symbol? (list-ref x 1)) ; #### + (boolean? (list-ref x 2)) + (list-of-require-specs? (list-ref x 3))) + (let ([drs-settings (super unmarshall-settings (first x))]) + (make-deinprogramm-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) + (cadddr x))) + (default-settings))) + + (define/private (list-of-require-specs? l) + (and (list? l) + (andmap (lambda (x) + (and (list? x) + (andmap (lambda (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)] + [scheme-test-module-name + ((current-module-name-resolver) '(lib "test-engine/scheme-tests.rkt") #f #f #t)] + [scheme-signature-module-name + ((current-module-name-resolver) '(lib "deinprogramm/signature/signature-german.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?)) + (ensure-drscheme-secrets-declared drs-namespace) + (namespace-attach-module drs-namespace ''drscheme-secrets) + (error-display-handler teaching-languages-error-display-handler) + + (current-eval (add-annotation (deinprogramm-lang-settings-tracing? settings) (current-eval))) + + (error-print-source-location #f) + (read-decimal-as-inexact #t) + (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? (preferences:get 'signatures:enable-checking?)) + (test-format (make-formatter (lambda (v o) + (render-value/format (if (procedure? v) + generic-proc + v) + settings o 40)))) + ))) + (super on-execute settings run-in-user-thread) + + ;; DeinProgramm addition, copied from language.rkt + (run-in-user-thread + (lambda () + (global-port-print-handler + (lambda (value port) + (let ([converted-value (simple-module-based-language-convert-value value settings)]) + (setup-printing-parameters + (lambda () + (parameterize ([pretty-print-columns 'infinity]) + (pretty-print converted-value port))) + settings + 'infinity))))))) + + ;; set-printing-parameters : settings ( -> TST) -> TST + ;; is implicitly exposed to the stepper. watch out! -- john + (define/public (set-printing-parameters settings thunk) + (parameterize ([pc:booleans-as-true/false #f] + [pc:abbreviate-cons-as-list (get-abbreviate-cons-as-list)] + [pretty-print-show-inexactness #f] + [pretty-print-exact-as-decimal #f] + [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) + (set-printing-parameters + settings + (lambda () + (simple-module-based-language-render-value/format value settings port width)))) + + (define/override (render-value value settings port) + (set-printing-parameters + settings + (lambda () + (simple-module-based-language-render-value/format value settings port 'infinity)))) + + (super-new))) + + ;; this inspector should be powerful enough to see + ;; any structure defined in the user's namespace + (define drscheme-inspector (current-inspector)) + + ;; FIXME: brittle, mimics drscheme-secrets + ;; as declared in lang/htdp-langs.rkt. + ;; Is it even needed for DeinProgramm langs? + ;; Only used by htdp/hangman teachpack. + (define (ensure-drscheme-secrets-declared drs-namespace) + (parameterize ((current-namespace drs-namespace)) + (define (declare) + (eval `(,#'module drscheme-secrets mzscheme + (provide drscheme-inspector) + (define drscheme-inspector ,drscheme-inspector))) + (namespace-require ''drscheme-secrets)) + (with-handlers ([exn:fail? (lambda (e) (declare))]) + ;; May have been declared by lang/htdp-langs tool, if loaded + (dynamic-require ''drscheme-secrets 'drscheme-inspector)) + (void))) + + + ;; { + ;; all this copied from collects/drracket/private/language.rkt + + ;; stepper-convert-value : TST settings -> TST + (define (stepper-convert-value value settings) + (define ((leave-snips-alone-hook sh) expr basic-convert sub-convert) + (if (or (is-a? expr snip%) + ;; FIXME: internal in language.rkt (to-snip-value? expr) + ) + expr + (sh expr basic-convert sub-convert))) + ;; mflatt: MINOR HACK - work around temporary + ;; print-convert problems + (define (stepper-print-convert v) + (or (and (procedure? v) (object-name v)) + (pc:print-convert v))) + + (case (drscheme:language:simple-settings-printing-style settings) + [(write) + (let ((v (convert-explicit value))) + (or (and (procedure? v) (object-name v)) + v))] + [(current-print) value] + [(constructor) + (parameterize + ([pc:constructor-style-printing #t] + [pc:show-sharing + (drscheme:language:simple-settings-show-sharing settings)] + [pc:current-print-convert-hook + (leave-snips-alone-hook (pc:current-print-convert-hook))]) + (stepper-print-convert value))] + [(quasiquote) + (parameterize + ([pc:constructor-style-printing #f] + [pc:show-sharing + (drscheme:language:simple-settings-show-sharing settings)] + [pc:current-print-convert-hook + (leave-snips-alone-hook (pc:current-print-convert-hook))]) + (stepper-print-convert value))] + [else (error "Internal stepper error: time to resync with simple-module-based-language-convert-value")])) + + ;; set-print-settings ; settings ( -> TST) -> TST + (define (set-print-settings language simple-settings thunk) + (if (method-in-interface? 'set-printing-parameters (object-interface language)) + (send language set-printing-parameters simple-settings thunk) + ;; assume that the current print-convert context is fine + ;; (error 'stepper-tool "language object does not contain set-printing-parameters method") + (thunk))) + + ;; simple-module-based-language-render-value/format : TST settings port (union #f (snip% -> void)) (union 'infinity number) -> void + (define (simple-module-based-language-render-value/format value settings port width) + (if (eq? (drscheme:language:simple-settings-printing-style settings) 'current-print) + (parameterize ([current-output-port port]) + ((current-print) value)) + (let ([converted-value (simple-module-based-language-convert-value value settings)]) + (setup-printing-parameters + (lambda () + (cond + [(drscheme:language:simple-settings-insert-newlines settings) + (if (number? width) + (parameterize ([pretty-print-columns width]) + (pretty-print converted-value port)) + (pretty-print converted-value port))] + [else + (parameterize ([pretty-print-columns 'infinity]) + (pretty-print converted-value port)) + (newline port)])) + settings + width)))) + + ;; setup-printing-parameters : (-> void) -> void + (define (setup-printing-parameters thunk settings width) + (let ([use-number-snip? + (lambda (x) + (and (number? x) + (exact? x) + (real? x) + (not (integer? x))))]) + (parameterize (;; these three handlers aren't used, but are set to override the user's settings + [pretty-print-print-line (lambda (line-number op old-line dest-columns) + (when (and (not (equal? line-number 0)) + (not (equal? dest-columns 'infinity))) + (newline op)) + 0)] + [pretty-print-pre-print-hook (lambda (val port) (void))] + [pretty-print-post-print-hook (lambda (val port) (void))] + + + [pretty-print-columns width] + [pretty-print-size-hook + (lambda (value display? port) + (cond + [(not (port-writes-special? port)) #f] + [(is-a? value snip%) 1] + [(use-number-snip? value) 1] + [(syntax? value) 1] + [(to-snip-value? value) 1] + [else #f]))] + [pretty-print-print-hook + (lambda (value display? port) + (cond + [(is-a? value snip%) + (write-special value port) + 1] + [(use-number-snip? value) + (write-special + (case (drscheme:language:simple-settings-fraction-style settings) + [(mixed-fraction) + (number-snip:make-fraction-snip value #f)] + [(mixed-fraction-e) + (number-snip:make-fraction-snip value #t)] + [(repeating-decimal) + (number-snip:make-repeating-decimal-snip value #f)] + [(repeating-decimal-e) + (number-snip:make-repeating-decimal-snip value #t)]) + port) + 1] + [(syntax? value) + (write-special (render-syntax/snip value) port)] + [else (write-special (value->snip value) port)]))] + [print-graph + ;; only turn on print-graph when using `write' printing + ;; style because the sharing is being taken care of + ;; by the print-convert sexp construction when using + ;; other printing styles. + (and (eq? (drscheme:language:simple-settings-printing-style settings) 'write) + (drscheme:language:simple-settings-show-sharing settings))]) + (thunk)))) + + ;; DeinProgramm changes in this procedure + ;; simple-module-based-language-convert-value : TST settings -> TST + (define (simple-module-based-language-convert-value value settings) + (case (drscheme:language:simple-settings-printing-style settings) + [(write) + ;; THIS IS THE CHANGE + (case (deinprogramm-lang-settings-writing-style settings) + [(explicit) (convert-explicit value)] + [(datum) value])] + [(current-print) value] + [(constructor) + (parameterize ([pc:constructor-style-printing #t] + [pc:show-sharing (drscheme:language:simple-settings-show-sharing settings)] + [pc:current-print-convert-hook (leave-snips-alone-hook (pc:current-print-convert-hook))]) + (pc:print-convert value))] + [(quasiquote) + (parameterize ([pc:constructor-style-printing #f] + [pc:show-sharing (drscheme:language:simple-settings-show-sharing settings)] + [pc:current-print-convert-hook (leave-snips-alone-hook (pc:current-print-convert-hook))]) + (pc:print-convert value))])) + + ;; leave-snips-alone-hook : any? (any? -> printable) any? -> printable + (define ((leave-snips-alone-hook sh) expr basic-convert sub-convert) + (if (is-a? expr snip%) + expr + (sh expr basic-convert sub-convert))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; snip/value extensions + ;; + + (define to-snips null) + (define-struct to-snip (predicate? >value)) + (define (add-snip-value predicate constructor) + (set! to-snips (cons (make-to-snip predicate constructor) to-snips))) + + (define (value->snip v) + (ormap (lambda (to-snip) (and ((to-snip-predicate? to-snip) v) + ((to-snip->value to-snip) v))) + to-snips)) + (define (to-snip-value? v) + (ormap (lambda (to-snip) ((to-snip-predicate? to-snip) v)) to-snips)) + + + ;; } + + ;; 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) + (let* ([parent (make-object vertical-panel% _parent)] + + [input-panel (instantiate group-box-panel% () + (parent parent) + (label (string-constant input-syntax)) + (alignment '(left center)))] + + [output-panel (instantiate group-box-panel% () + (parent parent) + (label (string-constant output-syntax)) + (alignment '(left center)))] + + [tp-group-box (instantiate group-box-panel% () + (label (string-constant teachpacks)) + (parent parent) + (alignment '(center top)))] + [tp-panel (new vertical-panel% + [parent tp-group-box] + [alignment '(center center)] + [stretchable-width #f] + [stretchable-height #f])] + + [case-sensitive (make-object check-box% + (string-constant case-sensitive-label) + input-panel + void)] + [output-style (make-object radio-box% + (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))) + output-panel + void)] + [writing-style (make-object radio-box% + "write-Ausgabe" + (list "explizit" + "Datum") + output-panel + void)] + [fraction-style + (make-object radio-box% (string-constant fraction-style) + (list (string-constant use-mixed-fractions) + (string-constant use-repeating-decimals)) + output-panel + void)] + [show-sharing #f] + [insert-newlines (make-object check-box% + (string-constant use-pretty-printer-label) + output-panel + void)] + + [tracing (new check-box% + (parent output-panel) + (label (string-constant tracing-enable-tracing)) + (callback void))] + + [tps '()]) + + (when allow-sharing-config? + (set! show-sharing + (instantiate 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) + + (case-lambda + [() + (make-deinprogramm-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 + (case (send writing-style get-selection) + [(0) 'explicit] + [(1) 'datum]) + (send tracing get-value) + tps)] + [(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] + [(write) 2] + [(print) 2]) + (case (drscheme:language:simple-settings-printing-style settings) + [(constructor) 0] + [(quasiquote) 0] + [(write) 1] + [(print) 1]))) + (send writing-style set-selection + (case (deinprogramm-lang-settings-writing-style settings) + [(explicit) 0] + [(datum) 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 (deinprogramm-lang-settings-teachpacks settings)) + (send tp-panel change-children (lambda (l) '())) + (if (null? tps) + (new message% + [parent tp-panel] + [label (string-constant teachpacks-none)]) + (for-each + (lambda (tp) (new message% + [parent tp-panel] + [label (format "~s" tp)])) + tps)) + (send tracing set-value (deinprogramm-lang-settings-tracing? settings)) + (void)]))) + + (define simple-deinprogramm-language% + ;; htdp-language<%> interface is here to make + ;; the "Racket | Disable Tests" menu item + ;; work for these languages + (class* drscheme:language:simple-module-based-language% (deinprogramm-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 #t) ;; #### should only be this in advanced mode + (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-deinprogramm-style-delta) style-delta) + + (super-instantiate () + (language-url "http://www.deinprogramm.de/dmda/")))) + + (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 (deinprogramm-lang-settings-teachpacks settings)) + + (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 " und " 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 " und " 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/private (tp-require->str tp) + (match tp + [`(lib ,x) + (define m (regexp-match #rx"teachpack/deinprogramm/(.*)$" x)) + (if m + (list-ref m 1) + (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 + (lambda (exe-name) + (create-embedding-executable + exe-name + #:modules `((#f ,program-filename)) + #:cmdline `("-l" + "scheme/base" + "-e" + ,(format "~s" `(#%require ',(filename->require-symbol program-filename)))) + #:src-filter + (lambda (path) (cannot-compile? path)) + #:get-extra-imports + (lambda (path cm) + (call-with-input-file path + (lambda (port) + (cond + [(is-wxme-stream? port) + (let-values ([(snip-class-names data-class-names) + (extract-used-classes port)]) + (list* + '(lib "wxme/read.ss") + '(lib "mred/mred.ss") + reader-module + (filter + values + (map (lambda (x) (string->lib-path x #t)) + (append + snip-class-names + data-class-names)))))] + [else + '()])))) + #:mred? #t)))))) + + (define/private (filename->require-symbol fn) + (let-values ([(base name dir) (split-path fn)]) + (string->symbol + (path->string + (path-replace-suffix name #""))))) + + (define/private (symbol-append x y) + (string->symbol + (string-append + (symbol->string x) + (symbol->string y)))) + + (inherit get-deinprogramm-style-delta) + (define/override (get-style-delta) + (get-deinprogramm-style-delta)) + + (inherit get-reader set-printing-parameters) + + (define/override (front-end/complete-program port settings) + (expand-teaching-program port + (get-reader) + (get-module) + (deinprogramm-lang-settings-teachpacks settings) + '#%deinprogramm)) + + (define/override (front-end/interaction port settings) + (let ([reader (get-reader)] ;; DeinProgramm addition: + ;; needed for test boxes; see + ;; the code in + ;; collects/drracket/private/language.rkt + [start? #t] + [done? #f]) + (λ () + (cond + [start? + (set! start? #f) + #'(#%plain-app reset-tests)] + [done? eof] + [else + (let ([ans (reader (object-name port) port)]) + (cond + [(eof-object? ans) + (set! done? #t) + #`(test)] + [else + ans]))])))) + + (define/augment (capability-value key) + (case key + [(drscheme:teachpack-menu-items) deinprogramm-teachpack-callbacks] + [(drscheme:special:insert-lambda) #f] + [else (inner (drscheme:language:get-capability-default key) + capability-value + key)])) + + (define deinprogramm-teachpack-callbacks + (drscheme:unit:make-teachpack-callbacks + (lambda (settings) + (map (lambda (x) (tp-require->str x)) (deinprogramm-lang-settings-teachpacks settings))) + (lambda (settings parent) + (define old-tps (deinprogramm-lang-settings-teachpacks settings)) + (define tp-dirs (list "deinprogramm")) + (define labels (list (string-constant teachpack-pre-installed))) + (define tp-syms '(deinprogramm-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))))) + + (preferences:set 'drracket:deinprogramm:last-set-teachpacks/multi-lib new-tps) + (make-deinprogramm-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) + (deinprogramm-lang-settings-writing-style settings) + (deinprogramm-lang-settings-tracing? settings) + new-tps)) + (lambda (settings name) + (let ([new-tps (filter (lambda (x) (not (equal? (tp-require->str x) name))) + (deinprogramm-lang-settings-teachpacks settings))]) + (preferences:set 'drracket:deinprogramm:last-set-teachpacks/multi-lib new-tps) + (make-deinprogramm-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) + (deinprogramm-lang-settings-writing-style settings) + (deinprogramm-lang-settings-tracing? settings) + new-tps))) + (lambda (settings) + (preferences:set 'drracket:deinprogramm:last-set-teachpacks/multi-lib '()) + (make-deinprogramm-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) + (deinprogramm-lang-settings-writing-style settings) + (deinprogramm-lang-settings-tracing? settings) + '())))) + + (inherit-field reader-module) + (define/override (get-reader-module) reader-module) + (define/override (get-metadata modname settings) + (define parsed-tps + (marshall-teachpack-settings + (deinprogramm-lang-settings-teachpacks settings))) + (string-append + ";; Die ersten drei Zeilen dieser Datei wurden von DrRacket eingefügt. Sie enthalten Metadaten\n" + ";; über die Sprachebene dieser Datei in einer Form, die DrRacket verarbeiten kann.\n" + (format "#reader~s~s\n" + reader-module + `((modname ,modname) + (read-case-sensitive ,(drscheme:language:simple-settings-case-sensitive settings)) + (teachpacks ,parsed-tps) + (deinprogramm-settings + ,(for/vector ([e (in-vector (deinprogramm-lang-settings->vector settings))] + [i (in-naturals)]) + (cond + [(= i deinprogramm-teachpacks-field-index) parsed-tps] + [else e]))))))) + + (inherit default-settings) + (define/override (metadata->settings metadata) + (let* ([table (metadata->table metadata)] ;; extract the table + [ssv (assoc 'deinprogramm-settings table)]) + (if ssv + (let ([settings-list (vector->list (cadr ssv))]) + (if (equal? (length settings-list) + (procedure-arity make-deinprogramm-lang-settings)) + (apply make-deinprogramm-lang-settings + (for/list ([i (in-naturals)] + [e (in-list settings-list)]) + (cond + [(= i deinprogramm-teachpacks-field-index) + (unmarshall-teachpack-settings e)] + [else e]))) + (default-settings))) + (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 (metadata->table metadata) + (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))) + + ;; cannot-compile? : path -> boolean + ;; returns #t if the file cannot be compiled, #f otherwise + (define (cannot-compile? path) + (call-with-input-file path + (lambda (port) + (let ([ok-to-compile-names + (map (lambda (x) (format "~s" x)) + '(wxtext + (lib "comment-snip.ss" "framework") + (lib "xml-snipclass.ss" "xml") + (lib "scheme-snipclass.ss" "xml") + (lib "test-case-box-snipclass.ss" "test-suite")))]) + (and (is-wxme-stream? port) + (let-values ([(snip-class-names data-class-names) + (extract-used-classes port)]) + (not (and (andmap + (lambda (used-name) (member used-name ok-to-compile-names)) + snip-class-names) + (andmap + (lambda (used-name) (member used-name ok-to-compile-names)) + data-class-names))))))))) + + (define (stepper-settings-language %) + (if (implementation? % stepper-language<%>) + (class* % (stepper-language<%>) + (init-field stepper:supported) + (define/override (stepper:supported?) stepper:supported) + (define/override (stepper:show-inexactness?) #f) + (define/override (stepper:print-boolean-long-form?) #f) + (define/override (stepper:show-consumed-and/or-clauses?) #f) + (define/override (stepper:render-to-sexp val settings language-level) + (parameterize ([pc:current-print-convert-hook (make-print-convert-hook settings)]) + (set-print-settings + language-level + settings + (lambda () + (stepper-convert-value val settings))))) + (super-new)) + (class % + (init stepper:supported) + (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)))) + + ;; make-print-convert-hook: + ;; simple-settings -> (TST (TST -> TST) (TST -> TST) -> TST) + ;; this code copied from various locations in language.rkt and rep.rkt + (define (make-print-convert-hook simple-settings) + (lambda (exp basic-convert sub-convert) + (cond + [(is-a? exp snip%) + (send exp copy)] + [else (basic-convert exp)]))) + + ;; 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))) + + + ; + ; + ; + ; + ; + ; ; + ; ;;; ; ; ; ; ;;; ; ; ;;;; ; ; ;;; ;;; ;;; + ; ; ; ;; ;; ; ; ;; ; ;; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ;;;;;; ; ; ; ; ; ; ; ;;;; ; ;;;;;; + ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ;;;; ; ; ;;; ; ;; ; ;;;;; ;;; ;;;; + ; + ; + ; + + (define mf-note + (let ([bitmap + (make-object bitmap% + (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)) + (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)) + + (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 (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) + (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 + ;; + + ;; WARNING: much code copied from "collects/lang/htdp-langs.rkt" + + (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 + (lambda () + (let ([on-sd (make-object style-delta%)] + [off-sd (make-object style-delta%)]) + (cond + [(preferences:get 'framework:white-on-black?) + (send on-sd set-delta-foreground "white") + (send off-sd set-delta-background "lightblue") + (send off-sd set-delta-foreground "black")] + [else + (send on-sd set-delta-foreground "black") + (send off-sd set-delta-background "lightblue") + (send off-sd set-delta-foreground "black")]) + (send rep set-test-coverage-info ht on-sd off-sd #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 'DMdA-langs + "internal-error: no test-coverage table"))] + [v (hash-ref ht expr + (lambda () + (error 'DMdA-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^))) + + ;; 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-deinprogramm-language : (instanceof deinprogramm-language<%>) -> void + (define (add-deinprogramm-language o) + (drscheme:language-configuration:add-language + o + #:allow-executable-creation? #t)) + + (define (phase1) (void)) + + ;; phase2 : -> void + (define (phase2) + (define (make-deinprogramm-language% printing-style writing-style) + (debugger-settings-language + (stepper-settings-language + ((drscheme:language:get-default-mixin) + (language-extension + (drscheme:language:module-based-language->language-mixin + (module-based-language-extension + printing-style writing-style + (drscheme:language:simple-module-based-language->module-based-language-mixin + simple-deinprogramm-language%)))))))) + + (add-deinprogramm-language + (instantiate (make-deinprogramm-language% 'write 'explicit) () + (module '(lib "deinprogramm/DMdA-beginner.rkt")) + (manual #"DMdA-beginner") + (language-position (list (string-constant teaching-languages) + "DeinProgramm" + "Die Macht der Abstraktion" + "Die Macht der Abstraktion - Anfänger")) + (language-id "DMdA:beginner") + (language-numbers '(-500 -300 300 3)) + (sharing-printing #f) + (abbreviate-cons-as-list #t) + (allow-sharing? #f) + (reader-module '(lib "DMdA-beginner-reader.ss" "deinprogramm")) + (stepper:supported #t))) + + (add-deinprogramm-language + (instantiate (make-deinprogramm-language% 'write 'explicit) () + (module '(lib "deinprogramm/DMdA-vanilla.rkt")) + (manual #"DMdA-vanilla") + (language-position (list (string-constant teaching-languages) + "DeinProgramm" + "Die Macht der Abstraktion" + "Die Macht der Abstraktion")) + (language-id "DMdA:vanilla") + (language-numbers '(-500 -300 300 4)) + (sharing-printing #f) + (abbreviate-cons-as-list #t) + (allow-sharing? #f) + (reader-module '(lib "DMdA-vanilla-reader.ss" "deinprogramm")) + (stepper:supported #t))) + + (add-deinprogramm-language + (instantiate (make-deinprogramm-language% 'write 'explicit) () + (module '(lib "deinprogramm/DMdA-assignments.rkt")) + (manual #"DMdA-assignments") + (language-position (list (string-constant teaching-languages) + "DeinProgramm" + "Die Macht der Abstraktion" + "Die Macht der Abstraktion mit Zuweisungen")) + (language-id "DMdA:assignments") + (language-numbers '(-500 -300 300 5)) + (sharing-printing #t) + (abbreviate-cons-as-list #t) + (allow-sharing? #t) + (reader-module '(lib "DMdA-assignments-reader.ss" "deinprogramm")) + (stepper:supported #f) + (debugger:supported #t))) + + (add-deinprogramm-language + (instantiate (make-deinprogramm-language% 'write 'datum) () + (module '(lib "deinprogramm/DMdA-advanced.rkt")) + (manual #"DMdA-advanced") + (language-position (list (string-constant teaching-languages) + "DeinProgramm" + "Die Macht der Abstraktion" + "Die Macht der Abstraktion - fortgeschritten")) + (language-id "DMdA:advanced") + (language-numbers '(-500 -300 300 6)) + (sharing-printing #t) + (abbreviate-cons-as-list #t) + (allow-sharing? #t) + (reader-module '(lib "DMdA-advanced-reader.ss" "deinprogramm")) + (stepper:supported #f) + (debugger:supported #t)))))) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/private/DMdA-reader.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/private/DMdA-reader.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/private/DMdA-reader.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/private/DMdA-reader.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,45 @@ +#lang scheme/base + + (require mzlib/etc) + (provide make-read-syntax + make-read) + + (define (make-read spec) + (let ([read + (opt-lambda ([port (current-input-port)]) + (syntax->datum ((make-read-syntax spec) 'whatever port)))]) + read)) + + (define (get-all-exps source-name port) + (let loop () + (let ([exp (read-syntax source-name port)]) + (cond + [(eof-object? exp) null] + [else (cons exp (loop))])))) + + (define (lookup key table) + (let ([ans (assoc key table)]) + (unless ans + (error 'special-reader "couldn't find ~s in table ~s" + key table)) + (cadr ans))) + + (define (make-read-syntax spec) + (let ([read-syntax + (opt-lambda ([source-name #f] + [port (current-input-port)]) + (let* ([table (read port)] + [path (object-name port)] + [modname + (if (path-string? path) + (let-values ([(base name dir) (split-path path)]) + (string->symbol (path->string (path-replace-suffix name #"")))) + (lookup 'modname table))]) + (datum->syntax + #f + `(module ,modname ,spec + ,@(map (lambda (x) `(require ,x)) + (lookup 'teachpacks table)) + ,@(parameterize ([read-case-sensitive (lookup 'read-case-sensitive table)]) + (get-all-exps source-name port))))))]) + read-syntax)) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/private/primitives.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/private/primitives.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/private/primitives.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/private/primitives.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,1296 @@ +#lang scheme/base + +(require syntax/docprovide) + +(require test-engine/scheme-tests + (lib "test-info.scm" "test-engine") + test-engine/scheme-tests + scheme/class) + +(require deinprogramm/signature/module-begin + (except-in deinprogramm/signature/signature signature-violation) + (except-in deinprogramm/signature/signature-syntax property)) + +(require (for-syntax scheme/base) + (for-syntax stepper/private/syntax-property) + (for-syntax syntax/parse) + (for-syntax racket/struct-info) + syntax/parse) + +(require deinprogramm/DMdA/define-record-procedures) + +(require (only-in lang/private/teachprims define-teach teach-equal? beginner-equal~?)) + +(require (for-syntax deinprogramm/private/syntax-checkers)) + +(require (rename-in deinprogramm/quickcheck/quickcheck + (property quickcheck:property))) + +(provide provide lib planet rename-out require #%datum #%module-begin #%top-interaction) ; so we can use this as a language + +(provide (all-from-out deinprogramm/DMdA/define-record-procedures)) +(provide (all-from-out test-engine/scheme-tests)) +(provide signature define-contract : + contract ; legacy + -> mixed one-of predicate combined list-of) + +(provide number real rational integer natural + boolean true false + string symbol + empty-list + unspecific + any + property) + +(provide match) + +(define-syntax provide/rename + (syntax-rules () + ((provide/rename (here there) ...) + (begin + (provide (rename-out (here there))) ...)))) + +(provide/rename + (DMdA-define define) + (DMdA-let let) + (DMdA-let* let*) + (DMdA-letrec letrec) + (DMdA-lambda lambda) + (DMdA-lambda λ) + (DMdA-cond cond) + (DMdA-if if) + (DMdA-else else) + (DMdA-begin begin) + (DMdA-and and) + (DMdA-or or) + (DMdA-dots ..) + (DMdA-dots ...) + (DMdA-dots ....) + (DMdA-dots .....) + (DMdA-dots ......) + (DMdA-app #%app) + (DMdA-top #%top) + (DMdA-set! set!) + (module-begin DMdA-module-begin)) + +(provide DMdA-advanced-lambda + DMdA-advanced-define) + +(provide for-all ==> + check-property + expect expect-within expect-member-of expect-range) + +(provide quote) + +(provide-and-document + procedures + ("Zahlen" + (number? (any -> boolean) + "feststellen, ob ein Wert eine Zahl ist") + + (= (number number number ... -> boolean) + "Zahlen auf Gleichheit testen") + (< (real real real ... -> boolean) + "Zahlen auf kleiner-als testen") + (> (real real real ... -> boolean) + "Zahlen auf größer-als testen") + (<= (real real real ... -> boolean) + "Zahlen auf kleiner-gleich testen") + (>= (real real real ... -> boolean) + "Zahlen auf größer-gleich testen") + + (+ (number number number ... -> number) + "Summe berechnen") + (- (number number ... -> number) + "bei mehr als einem Argument Differenz zwischen der ersten und der Summe aller weiteren Argumente berechnen; bei einem Argument Zahl negieren") + (* (number number number ... -> number) + "Produkt berechnen") + (/ (number number number ... -> number) + "das erste Argument durch das Produkt aller weiteren Argumente berechnen") + (max (real real ... -> real) + "Maximum berechnen") + (min (real real ... -> real) + "Minimum berechnen") + (quotient (integer integer -> integer) + "ganzzahlig dividieren") + (remainder (integer integer -> integer) + "Divisionsrest berechnen") + (modulo (integer integer -> integer) + "Divisionsmodulo berechnen") + (sqrt (number -> number) + "Quadratwurzel berechnen") + (expt (number number -> number) + "Potenz berechnen (erstes Argument hoch zweites Argument)") + (abs (real -> real) + "Absolutwert berechnen") + + ;; fancy numeric + (exp (number -> number) + "Exponentialfunktion berechnen (e hoch Argument)") + (log (number -> number) + "natürlichen Logarithmus (Basis e) berechnen") + + ;; trigonometry + (sin (number -> number) + "Sinus berechnen (Argument in Radian)") + (cos (number -> number) + "Cosinus berechnen (Argument in Radian)") + (tan (number -> number) + "Tangens berechnen (Argument in Radian)") + (asin (number -> number) + "Arcussinus berechnen (in Radian)") + (acos (number -> number) + "Arcuscosinus berechnen (in Radian)") + (atan (number -> number) + "Arcustangens berechnen (in Radian)") + + (exact? (number -> boolean) + "feststellen, ob eine Zahl exakt ist") + + (integer? (any -> boolean) + "feststellen, ob ein Wert eine ganze Zahl ist") + (natural? (any -> boolean) + "feststellen, ob ein Wert eine natürliche Zahl (inkl. 0) ist") + + (zero? (number -> boolean) + "feststellen, ob eine Zahl Null ist") + (positive? (number -> boolean) + "feststellen, ob eine Zahl positiv ist") + (negative? (number -> boolean) + "feststellen, ob eine Zahl negativ ist") + (odd? (integer -> boolean) + "feststellen, ob eine Zahl ungerade ist") + (even? (integer -> boolean) + "feststellen, ob eine Zahl gerade ist") + + (lcm (integer integer ... -> natural) + "kleinstes gemeinsames Vielfaches berechnen") + + (gcd (integer integer ... -> natural) + "größten gemeinsamen Teiler berechnen") + + (rational? (any -> boolean) + "feststellen, ob eine Zahl rational ist") + + (numerator (rational -> integer) + "Zähler eines Bruchs berechnen") + + (denominator (rational -> natural) + "Nenner eines Bruchs berechnen") + + (inexact? (number -> boolean) + "feststellen, ob eine Zahl inexakt ist") + + (real? (any -> boolean) + "feststellen, ob ein Wert eine reelle Zahl ist") + + (floor (real -> integer) + "nächste ganze Zahl unterhalb einer rellen Zahlen berechnen") + + (ceiling (real -> integer) + "nächste ganze Zahl oberhalb einer rellen Zahlen berechnen") + + (round (real -> integer) + "relle Zahl auf eine ganze Zahl runden") + + (complex? (any -> boolean) + "feststellen, ob ein Wert eine komplexe Zahl ist") + + (make-polar (real real -> number) + "komplexe Zahl aus Abstand zum Ursprung und Winkel berechnen") + + (real-part (number -> real) + "reellen Anteil einer komplexen Zahl extrahieren") + + (imag-part (number -> real) + "imaginären Anteil einer komplexen Zahl extrahieren") + + (magnitude (number -> real) + "Abstand zum Ursprung einer komplexen Zahl berechnen") + + (angle (number -> real) + "Winkel einer komplexen Zahl berechnen") + + (exact->inexact (number -> number) + "eine Zahl durch eine inexakte Zahl annähern") + + (inexact->exact (number -> number) + "eine Zahl durch eine exakte Zahl annähern") + + ;; "Odds and ends" + + (number->string (number -> string) + "Zahl in Zeichenkette umwandeln") + + (string->number (string -> (mixed number false)) + "Zeichenkette in Zahl umwandeln, falls möglich") + + (random (natural -> natural) + "eine natürliche Zufallszahl berechnen, die kleiner als das Argument ist") + + (current-seconds (-> natural) + "aktuelle Zeit in Sekunden seit einem unspezifizierten Startzeitpunkt berechnen")) + + ("boolesche Werte" + (boolean? (any -> boolean) + "feststellen, ob ein Wert ein boolescher Wert ist") + + ((DMdA-not not) (boolean -> boolean) + "booleschen Wert negieren") + + (boolean=? (boolean boolean -> boolean) + "Booleans auf Gleichheit testen") + + (true? (any -> boolean) + "feststellen, ob ein Wert #t ist") + (false? (any -> boolean) + "feststellen, ob ein Wert #f ist")) + + ("Listen" + (empty list "die leere Liste") + (make-pair (%a (list-of %a) -> (list-of %a)) + "erzeuge ein Paar aus Element und Liste") + ((DMdA-cons cons) (%a (list-of %a) -> (list-of %a)) + "erzeuge ein Paar aus Element und Liste") + (pair? (any -> boolean) + "feststellen, ob ein Wert ein Paar ist") + (cons? (any -> boolean) + "feststellen, ob ein Wert ein Paar ist") + (empty? (any -> boolean) + "feststellen, ob ein Wert die leere Liste ist") + + (first ((list-of %a) -> %a) + "erstes Element eines Paars extrahieren") + (rest ((list-of %a) -> (list-of %a)) + "Rest eines Paars extrahieren") + + (list (%a ... -> (list-of %a)) + "Liste aus den Argumenten konstruieren") + + (length ((list-of %a) -> natural) + "Länge einer Liste berechnen") + + (fold (%b (%a %b -> %b) (list-of %a) -> %b) + "Liste einfalten.") + + ((DMdA-append append) ((list-of %a) ... -> (list-of %a)) + "mehrere Listen aneinanderhängen") + + (list-ref ((list-of %a) natural -> %a) + "das Listenelement an der gegebenen Position extrahieren") + + (reverse ((list-of %a) -> (list-of %a)) + "Liste in umgekehrte Reihenfolge bringen")) + + ("Computer" + (computer signature + "Signatur für Computer") + (make-computer (string rational rational -> computer) + "Computer aus Prozessorname, Arbeitsspeicher und Festplattenkapazität konstruieren") + (computer? (any -> boolean) + "feststellen, ob Wert ein Computer ist") + (computer-processor (computer -> string) + "Prozessorname aus Computer extrahieren") + (computer-ram (computer -> rational) + "Arbeitsspeicher aus Computer extrahieren") + (computer-hard-drive (computer -> rational) + "Festplattenkapazität aus Computer extrahieren")) + + ("Schokokekse" + (chocolate-cookie signature + "Signatur für Schokokekse") + (make-chocolate-cookie (number number -> chocolate-cookie) + "Schokokeks aus Schoko- und Keks-Anteil konstruieren") + (chocolate-cookie? (any -> boolean) + "feststellen, ob ein Wert ein Schokokeks ist") + (chocolate-cookie-chocolate (chocolate-cookie -> number) + "Schoko-Anteil eines Schokokekses extrahieren") + (chocolate-cookie-cookie (chocolate-cookie -> number) + "Keks-Anteil eines Schokokekses extrahieren")) + + ;; #### Zeichen sollten noch dazu, Vektoren wahrscheinlich auch + + ("Zeichenketten" + (string? (any -> boolean) + "feststellen, ob ein Wert eine Zeichenkette ist") + + (string=? (string string string ... -> boolean) + "Zeichenketten auf Gleichheit testen") + (string boolean) + "Zeichenketten lexikografisch auf kleiner-als testen") + (string>? (string string string ... -> boolean) + "Zeichenketten lexikografisch auf größer-als testen") + (string<=? (string string string ... -> boolean) + "Zeichenketten lexikografisch auf kleiner-gleich testen") + (string>=? (string string string ... -> boolean) + "Zeichenketten lexikografisch auf größer-gleich testen") + + (string-append (string string ... -> string) + "Hängt Zeichenketten zu einer Zeichenkette zusammen") + + (strings-list->string ((list string) -> string) + "Eine Liste von Zeichenketten in eine Zeichenkette umwandeln") + + (string->strings-list (string -> (list string)) + "Eine Zeichenkette in eine Liste von Zeichenketten mit einzelnen Zeichen umwandeln") + + (string-length (string -> natural) + "Liefert Länge einer Zeichenkette")) + + ("Symbole" + (symbol? (any -> boolean) + "feststellen, ob ein Wert ein Symbol ist") + (symbol=? (symbol symbol -> boolean) + "Sind zwei Symbole gleich?") + (symbol->string (symbol -> string) + "Symbol in Zeichenkette umwandeln") + (string->symbol (string -> symbol) + "Zeichenkette in Symbol umwandeln")) + + ("Verschiedenes" + (equal? (%a %b -> boolean) + "zwei Werte auf Gleichheit testen") + (eq? (%a %b -> boolean) + "zwei Werte auf Selbheit testen") + ((DMdA-write-string write-string) (string -> unspecific) + "Zeichenkette in REPL ausgeben") + (write-newline (-> unspecific) + "Zeilenumbruch ausgeben") + (violation (string -> unspecific) + "Programmm mit Fehlermeldung abbrechen") + + (map ((%a -> %b) (list %a) -> (list %b)) + "Prozedur auf alle Elemente einer Liste anwenden, Liste der Resultate berechnen") + (for-each ((%a -> %b) (list %a) -> unspecific) + "Prozedur von vorn nach hinten auf alle Elemente einer Liste anwenden") + (apply (procedure (list %a) -> %b) + "Prozedur auf Liste ihrer Argumente anwenden") + (read (-> any) + "Externe Repräsentation eines Werts in der REPL einlesen und den zugehörigen Wert liefern"))) + +(define real-make-pair + (let () + (define make-pair + (procedure-rename + (lambda (f r) + (when (and (not (null? r)) + (not (pair? r))) + (raise + (make-exn:fail:contract + (string->immutable-string + (format "Zweites Argument zu make-pair ist keine Liste, sondern ~e" r)) + (current-continuation-marks)))) + (cons f r)) + 'make-pair)) + make-pair)) + +(define-syntax make-pair + (let () + ;; make it work with match + (define-struct pair-info () + #:super struct:struct-info + #:property + prop:procedure + (lambda (_ stx) + (syntax-case stx () + ((self . args) (syntax/loc stx (real-make-pair . args))) + (else (syntax/loc stx real-make-pair))))) + (make-pair-info (lambda () + (list #f + #'real-make-pair + #'pair? + (list #'cdr #'car) + '(#f #f) + #f))))) + +(define (first l) + (when (not (pair? l)) + (raise + (make-exn:fail:contract + (string->immutable-string + (format "Argument zu first kein Paar, sondern ~e" l)) + (current-continuation-marks)))) + (car l)) + +(define (rest l) + (when (not (pair? l)) + (raise + (make-exn:fail:contract + (string->immutable-string + (format "Argument zu rest kein Paar, sondern ~e" l)) + (current-continuation-marks)))) + (cdr l)) + +(define empty '()) + +(define (empty? obj) + (null? obj)) + +(define (cons? obj) + (pair? obj)) + +(define-teach DMdA cons + (lambda (f r) + (make-pair f r))) + +(define-teach DMdA append + (lambda args + (let loop ((args args) + (seen-rev '())) + (when (not (null? args)) + (let ((arg (car args))) + (when (and (not (null? arg)) + (not (pair? arg))) + (raise + (make-exn:fail:contract + (string->immutable-string + (format "Argument zu append keine Liste, sondern ~e; restliche Argumente:~a" + arg + (apply string-append + (map (lambda (arg) + (format " ~e" arg)) + (append (reverse seen-rev) + (list '<...>) + (cdr args)))))) + (current-continuation-marks)))) + (loop (cdr args) + (cons arg seen-rev))))) + + (apply append args))) + +(define fold + (lambda (unit combine lis) + (cond + ((empty? lis) unit) + ((pair? lis) + (combine (first lis) + (fold unit combine (rest lis)))) + (else + (raise + (make-exn:fail:contract + (string->immutable-string + (format "Argument zu fold keine Liste, sondern ~e; andere Argumente: ~e ~e" + lis + unit combine)) + (current-continuation-marks))))))) + +;; This is copied from collects/lang/private/beginner-funs.rkt +;; Test-suite support (require is really an effect +;; to make sure that it's loaded) +(require deinprogramm/test-suite) + +(define-for-syntax (binding-in-this-module? b) + (and (list? b) + (module-path-index? (car b)) + (let-values (((path base) (module-path-index-split (car b)))) + (and (not path) (not base))))) + +(define-for-syntax (transform-DMdA-define stx mutable?) + (unless (memq (syntax-local-context) '(module top-level)) + (raise-syntax-error + #f "Define muss ganz außen stehen" stx)) + (syntax-case stx () + ((DMdA-define) + (raise-syntax-error + #f "Definition ohne Operanden" stx)) + ((DMdA-define v) + (raise-syntax-error + #f "Define erwartet zwei Operanden, nicht einen" stx)) + ((DMdA-define var expr) + (begin + (check-for-id! + (syntax var) + "Der erste Operand der Definition ist kein Name") + + (let ((binding (identifier-binding (syntax var)))) + (when binding + (if (binding-in-this-module? binding) + (raise-syntax-error + #f + "Zweite Definition für denselben Namen" + stx) + (raise-syntax-error + #f + "Dieser Name gehört einer eingebauten Prozedur und kann nicht erneut definiert werden" (syntax var))))) + (if mutable? + (with-syntax + ((dummy-def (stepper-syntax-property + (syntax (define dummy (lambda () (set! var 'dummy)))) + 'stepper-skip-completely + #t))) + (syntax/loc stx + (begin + dummy-def + (define var expr)))) + (syntax/loc stx (define var expr))))) + ((DMdA-define v e1 e2 e3 ...) + (raise-syntax-error + #f "Definition mit mehr als zwei Operanden" stx)))) + +(define-syntax (DMdA-define stx) + (transform-DMdA-define stx #f)) + +(define-syntax (DMdA-advanced-define stx) + (transform-DMdA-define stx #t)) + +(define-syntax (DMdA-let stx) + (syntax-case stx () + ((DMdA-let () body) + (syntax/loc stx body)) + ((DMdA-let ((var expr) ...) body) + (begin + (check-for-id-list! + (syntax->list (syntax (var ...))) + "Kein Name in Let-Bindung") + (syntax/loc stx ((lambda (var ...) body) expr ...)))) + ((DMdA-let ((var expr) ...) body1 body2 ...) + (raise-syntax-error + #f "Let-Ausdruck hat mehr als einen Ausdruck als Rumpf" stx)) + ((DMdA-let expr ...) + (raise-syntax-error + #f "Let-Ausdruck erwartet eine Liste von Bindungen (Paare aus Name und Ausdruck) und einen Rumpf" stx)))) + +(define-syntax (DMdA-let* stx) + (syntax-case stx () + ((DMdA-let* () body) + (syntax/loc stx body)) + ((DMdA-let* ((var1 expr1) (var2 expr2) ...) body) + (begin + (check-for-id! + (syntax var1) + "Kein Name in Let*-Bindung") + (syntax/loc stx ((lambda (var1) + (DMdA-let* ((var2 expr2) ...) body)) + expr1)))) + ((DMdA-let* ((var expr) ...) body1 body2 ...) + (raise-syntax-error + #f "Let*-Ausdruck hat mehr als einen Ausdruck als Rumpf" stx)) + ((DMdA-let* expr ...) + (raise-syntax-error + #f "Let*-Ausdruck erwartet eine Liste von Bindungen (Paare aus Name und Ausdruck) und einen Rumpf" stx)))) + +(define-syntax (DMdA-letrec stx) + (syntax-case stx () + ((DMdA-letrec ((var expr) ...) body) + (begin + (check-for-id-list! + (syntax->list (syntax (var ...))) + "Kein Name in letrec-Bindung") + (syntax/loc stx (letrec ((var expr) ...) body)))) + ((DMdA-letrec ((var expr) ...) body1 body2 ...) + (raise-syntax-error + #f "Letrec hat mehr als einen Ausdruck als Rumpf" stx)))) + +(define-syntax (DMdA-lambda stx) + (syntax-case stx () + ((DMdA-lambda (var ...) body) + (begin + (check-for-id-list! + (syntax->list (syntax (var ...))) + "Kein Name als Parameter der Lambda-Abstraktion") + (syntax/loc stx (lambda (var ...) body)))) + ((DMdA-lambda (var ...) body1 body2 ...) + (raise-syntax-error + #f "Lambda-Abstraktion hat mehr als einen Ausdruck als Rumpf" stx)) + ((DMdA-lambda var body ...) + (identifier? (syntax var)) + (raise-syntax-error + #f "Um die Parameter einer Lambda-Abstraktion gehören Klammern" (syntax var))) + ((DMdA-lambda var ...) + (raise-syntax-error + #f "Fehlerhafte Lambda-Abstraktion" stx)))) + +(define-syntax (DMdA-advanced-lambda stx) + (syntax-case stx () + ((DMdA-lambda (var ...) body) + (begin + (check-for-id-list! + (syntax->list (syntax (var ...))) + "Kein Name als Parameter der Lambda-Abstraktion") + (syntax/loc stx (lambda (var ...) body)))) + ((DMdA-lambda (var ... . rest) body) + (begin + (check-for-id-list! + (syntax->list (syntax (var ...))) + "Kein Name als Parameter der Lambda-Abstraktion") + (check-for-id! + (syntax rest) + "Kein Name als Restlisten-Parameter der Lambda-Abstraktion") + (syntax/loc stx (lambda (var ... . rest) body)))) + ((DMdA-lambda (var ...) body1 body2 ...) + (raise-syntax-error + #f "Lambda-Abstraktion hat mehr als einen Ausdruck als Rumpf" stx)) + ((DMdA-lambda var ...) + (raise-syntax-error + #f "Fehlerhafte Lambda-Abstraktion" stx)))) + +(define-syntax (DMdA-begin stx) + (syntax-case stx () + ((DMdA-begin) + (raise-syntax-error + #f "Begin-Ausdruck braucht mindestens einen Operanden" stx)) + ((DMdA-begin expr1 expr2 ...) + (syntax/loc stx (begin expr1 expr2 ...))))) + +(define-for-syntax (local-expand-for-error stx ctx stops) + ;; This function should only be called in an 'expression + ;; context. In case we mess up, avoid bogus error messages. + (when (memq (syntax-local-context) '(expression)) + (local-expand stx ctx stops))) + +(define-for-syntax (ensure-expression stx k) + (if (memq (syntax-local-context) '(expression)) + (k) + (stepper-syntax-property #`(begin0 #,stx) 'stepper-skipto skipto/second))) + +;; A consistent pattern for stepper-skipto: +(define-for-syntax (stepper-ignore-checker stx) + (stepper-syntax-property stx 'stepper-skipto '(syntax-e cdr syntax-e cdr car))) + +;; Raise a syntax error: +(define-for-syntax (teach-syntax-error form stx detail msg . args) + (let ([form (if (eq? form '|function call|) ; #### + form + #f)] ; extract name from stx + [msg (apply format msg args)]) + (if detail + (raise-syntax-error form msg stx detail) + (raise-syntax-error form msg stx)))) + +;; The syntax error when a form's name doesn't follow a "(" +(define-for-syntax (bad-use-error name stx) + (teach-syntax-error + name + stx + #f + "`~a' wurde an einer Stelle gefunden, die keiner offenen Klammer folgt" + name)) + +;; Use for messages "expected ..., found " +(define-for-syntax (something-else v) + (let ([v (syntax-e v)]) + (cond + [(number? v) "eine Zahl"] + [(string? v) "eine Zeichenkette"] + [else "etwas anderes"]))) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; cond +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-syntax (DMdA-cond stx) + (ensure-expression + stx + (lambda () + (syntax-case stx () + [(_) + (teach-syntax-error + 'cond + stx + #f + "Frage und eine Antwort nach `cond' erwartet, aber da ist nichts")] + [(_ clause ...) + (let* ([clauses (syntax->list (syntax (clause ...)))] + [check-preceding-exprs + (lambda (stop-before) + (let/ec k + (for-each (lambda (clause) + (if (eq? clause stop-before) + (k #t) + (syntax-case clause () + [(question answer) + (begin + (unless (and (identifier? (syntax question)) + (free-identifier=? (syntax question) #'DMdA-else)) + (local-expand-for-error (syntax question) 'expression null)) + (local-expand-for-error (syntax answer) 'expression null))]))) + clauses)))]) + (let ([checked-clauses + (map + (lambda (clause) + (syntax-case clause (DMdA-else) + [(DMdA-else answer) + (let ([lpos (memq clause clauses)]) + (when (not (null? (cdr lpos))) + (teach-syntax-error + 'cond + stx + clause + "`else'-Test gefunden, der nicht am Ende des `cond'-Ausdrucks steht")) + (with-syntax ([new-test (stepper-syntax-property (syntax #t) 'stepper-else #t)]) + (syntax/loc clause (new-test answer))))] + [(question answer) + (with-syntax ([verified (stepper-ignore-checker (syntax (verify-boolean question 'cond)))]) + (syntax/loc clause (verified answer)))] + [() + (check-preceding-exprs clause) + (teach-syntax-error + 'cond + stx + clause + "Test und Ausdruck in Zweig erwartet, aber Zweig leer")] + [(question?) + (check-preceding-exprs clause) + (teach-syntax-error + 'cond + stx + clause + "Zweig mit Test und Ausdruck erwartet, aber Zweig enthält nur eine Form")] + [(question? answer? ...) + (check-preceding-exprs clause) + (let ([parts (syntax->list clause)]) + ;; to ensure the illusion of left-to-right checking, make sure + ;; the question and first answer (if any) are ok: + (unless (and (identifier? (car parts)) + (free-identifier=? (car parts) #'DMdA-else)) + (local-expand-for-error (car parts) 'expression null)) + (unless (null? (cdr parts)) + (local-expand-for-error (cadr parts) 'expression null)) + ;; question and answer (if any) are ok, raise a count-based exception: + (teach-syntax-error + 'cond + stx + clause + "Zweig mit Test und Ausdruck erwartet, aber Zweig enthält ~a Formen" + (length parts)))] + [_else + (teach-syntax-error + 'cond + stx + clause + "Zweig mit Test und Ausdruck erwartet, aber ~a gefunden" + (something-else clause))])) + clauses)]) + ;; Add `else' clause for error (always): + (let ([clauses (append checked-clauses + (list + (with-syntax ([error-call (syntax/loc stx (error 'cond "alle Tests ergaben #f"))]) + (syntax [else error-call]))))]) + (with-syntax ([clauses clauses]) + (syntax/loc stx (cond . clauses))))))] + [_else (bad-use-error 'cond stx)])))) + +(define-syntax DMdA-else + (make-set!-transformer + (lambda (stx) + (define (bad expr) + (teach-syntax-error + 'else + expr + #f + "hier nicht erlaubt, weil kein Test in `cond'-Zweig")) + (syntax-case stx (set! x) + [(set! e expr) (bad #'e)] + [(e . expr) (bad #'e)] + [e (bad stx)])))) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; if +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-syntax (DMdA-if stx) + (ensure-expression + stx + (lambda () + (syntax-case stx () + [(_ test then else) + (with-syntax ([new-test (stepper-ignore-checker (syntax (verify-boolean test 'if)))]) + (syntax/loc stx + (if new-test + then + else)))] + [(_ . rest) + (let ([n (length (syntax->list (syntax rest)))]) + (teach-syntax-error + 'if + stx + #f + "Test und zwei Ausdrücke erwartet, aber ~a Form~a gefunden" + (if (zero? n) "keine" n) + (if (= n 1) "" "en")))] + [_else (bad-use-error 'if stx)])))) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; or, and +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-syntaxes (DMdA-or DMdA-and) + (let ([mk + (lambda (where) + (let ([stepper-tag (case where + [(or) 'comes-from-or] + [(and) 'comes-from-and])]) + (with-syntax ([swhere where]) + (lambda (stx) + (ensure-expression + stx + (lambda () + (syntax-case stx () + [(_ . clauses) + (let ([n (length (syntax->list (syntax clauses)))]) + (let loop ([clauses-consumed 0] + [remaining (syntax->list #`clauses)]) + (if (null? remaining) + (case where + [(or) #`#f] + [(and) #`#t]) + (stepper-syntax-property + (stepper-syntax-property + (quasisyntax/loc + stx + (if #,(stepper-ignore-checker (quasisyntax/loc stx (verify-boolean #,(car remaining) 'swhere))) + #,@(case where + [(or) #`(#t + #,(loop (+ clauses-consumed 1) (cdr remaining)))] + [(and) #`(#,(loop (+ clauses-consumed 1) (cdr remaining)) + #f)]))) + 'stepper-hint + stepper-tag) + 'stepper-and/or-clauses-consumed + clauses-consumed))))] + [_else (bad-use-error where stx)])))))))]) + (values (mk 'or) (mk 'and)))) + +;; verify-boolean is inserted to check for boolean results: +(define (verify-boolean b where) + (if (or (eq? b #t) (eq? b #f)) + b + (raise + (make-exn:fail:contract + (string->immutable-string + (format "~a: Testresultat ist nicht boolesch: ~e" where b)) + (current-continuation-marks))))) + +(define-teach DMdA not + (lambda (b) + (verify-boolean b 'not) + (not b))) + +(define (boolean=? a b) + (verify-boolean a 'boolean=?) + (verify-boolean b 'boolean=?) + (eq? a b)) + +(define (verify-symbol b where) + (if (symbol? b) + b + (raise + (make-exn:fail:contract + (string->immutable-string + (format "~a: Wert ist kein Symbol: ~e" where b)) + (current-continuation-marks))))) + +(define (symbol=? a b) + (verify-symbol a 'symbol=?) + (verify-symbol b 'symbol=?) + (eq? a b)) + +(define-syntax (DMdA-app stx) + (syntax-case stx () + ((_) + (raise-syntax-error + #f "Zusammengesetzte Form ohne Operator" (syntax/loc stx ()))) + ((_ datum1 datum2 ...) + (let ((scm-datum (syntax->datum (syntax datum1)))) + (or (number? scm-datum) + (boolean? scm-datum) + (string? scm-datum) + (char? scm-datum))) + (raise-syntax-error #f "Operator darf kein Literal sein" (syntax datum1))) + ((_ datum1 datum2 ...) + (syntax/loc stx (#%app datum1 datum2 ...))))) + +(define-syntax (DMdA-top stx) + (syntax-case stx () + ((_ . id) + ;; If we're in a module, we'll need to check that the name + ;; is bound.... + (if (and (not (identifier-binding #'id)) + (syntax-source-module #'id)) + ;; ... but it might be defined later in the module, so + ;; delay the check. + (stepper-ignore-checker + (syntax/loc stx (#%app values (DMdA-top-continue id)))) + (syntax/loc stx (#%top . id)))))) + +(define-syntax (DMdA-top-continue stx) + (syntax-case stx () + [(_ id) + ;; If there's still no binding, it's an "unknown name" error. + (if (not (identifier-binding #'id)) + (raise-syntax-error #f "Ungebundene Variable" (syntax/loc stx id)) + ;; Don't use #%top here; id might have become bound to something + ;; that isn't a value. + #'id)])) + +(define-teach DMdA write-string + (lambda (s) + (when (not (string? s)) + (error "Argument von write-string ist keine Zeichenkette")) + (display s))) + +(define (write-newline) + (newline)) + +(define-record-procedures chocolate-cookie + make-chocolate-cookie chocolate-cookie? + (chocolate-cookie-chocolate chocolate-cookie-cookie)) + +(define-record-procedures computer + make-computer computer? + (computer-processor + computer-ram + computer-hard-drive)) + +(define (violation text) + (error text)) + +(define (string->strings-list s) + (map (lambda (c) (make-string 1 c)) (string->list s))) + +(define (strings-list->string l) + (if (null? l) + "" + (string-append (car l) (strings-list->string (cdr l))))) + +(define integer (signature/arbitrary arbitrary-integer (predicate integer?))) +(define number (signature/arbitrary arbitrary-real (predicate number?))) +(define rational (signature/arbitrary arbitrary-rational (predicate rational?))) +(define real (signature/arbitrary arbitrary-real (predicate real?))) + +(define (natural? x) + (and (integer? x) + (not (negative? x)))) + +(define natural (signature/arbitrary arbitrary-natural (predicate natural?))) + +(define boolean (signature/arbitrary arbitrary-boolean (predicate boolean?))) + +(define (true? x) + (eq? x #t)) + +(define (false? x) + (eq? x #f)) + +(define true (signature (one-of #t))) +(define false (signature (one-of #f))) + +(define string (signature/arbitrary arbitrary-printable-ascii-string (predicate string?))) +(define symbol (signature/arbitrary arbitrary-symbol (predicate symbol?))) +(define empty-list (signature (one-of empty))) + +(define unspecific (signature unspecific %unspecific)) +(define any (signature any %any)) + +;; aus collects/lang/private/teach.rkt + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; dots (.. and ... and .... and ..... and ......) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Syntax Identifier -> Expression +;; Produces an expression which raises an error reporting unfinished code. +(define-for-syntax (dots-error stx name) + (quasisyntax/loc stx + (error (quote (unsyntax name)) + "Fertiger Ausdruck erwartet, aber da sind noch Ellipsen"))) + +;; Expression -> Expression +;; Transforms unfinished code (... and the like) to code +;; raising an appropriate error. +(define-syntax DMdA-dots + (make-set!-transformer + (lambda (stx) + (syntax-case stx (set!) + [(set! form expr) (dots-error stx (syntax form))] + [(form . rest) (dots-error stx (syntax form))] + [form (dots-error stx stx)])))) + +(define-syntaxes (DMdA-set! DMdA-set!-continue) + (let ((proc + (lambda (continuing?) + (lambda (stx) + (ensure-expression + stx + (lambda () + (syntax-case stx () + ((_ id expr) + (identifier? (syntax id)) + (begin + ;; Check that id isn't syntax, and not lexical. + ((with-handlers ((exn:fail? (lambda (exn) void))) + ;; First try syntax: + ;; If it's a transformer binding, then it can take care of itself... + (if (set!-transformer? (syntax-local-value (syntax id))) + void ;; no lex check wanted + (lambda () + (raise-syntax-error + #f + "Nach set! wird eine gebundene Variable erwartet, aber da ist ein Schlüsselwort." + stx))))) + ;; If we're in a module, we'd like to check here whether + ;; the identier is bound, but we need to delay that check + ;; in case the id is defined later in the module. So only + ;; do this in continuing mode: + (when continuing? + (when (and (not (identifier-binding #'id)) + (syntax-source-module #'id)) + (raise-syntax-error #f "Ungebundene Variable" #'id))) + (if continuing? + (syntax/loc stx (set! id expr)) + (stepper-ignore-checker (syntax/loc stx (#%app values (DMdA-set!-continue id expr))))))) + ((_ id expr) + (raise-syntax-error + #f + "Nach set! wird eine Variable aber da ist etwas anderes." + #'id)) + ((_ id) + (raise-syntax-error + #f + "Nach set! wird eine Variable und ein Ausdruck erwartet - der Ausdruck fehlt." + stx)) + ((_) + (raise-syntax-error + #f + "Nach set! wird eine Variable und ein Ausdruck erwartet, aber da ist nichts." + stx)) + (_else + (raise-syntax-error + #f + "Inkorrekter set!-Ausdruck." + stx))))))))) + (values (proc #f) + (proc #t)))) + +; QuickCheck + +(define-syntax (for-all stx) + (syntax-case stx () + ((_ (?clause ...) ?body) + (with-syntax ((((?id ?arb) ...) + (map (lambda (pr) + (syntax-case pr () + ((?id ?signature) + (identifier? #'?id) + (with-syntax ((?error-call + (syntax/loc #'?signature (error "Signatur hat keinen Generator")))) + #'(?id + (or (signature-arbitrary (signature ?signature)) + ?error-call)))) + (_ + (raise-syntax-error #f "inkorrekte `for-all'-Klausel - sollte die Form (id contr) haben" + pr)))) + (syntax->list #'(?clause ...))))) + + (stepper-syntax-property #'(quickcheck:property + ((?id ?arb) ...) ?body) + 'stepper-skip-completely + #t))) + ((_ ?something ?body) + (raise-syntax-error #f "keine Klauseln der Form (id contr)" + stx)) + ((_ ?thing1 ?thing2 ?thing3 ?things ...) + (raise-syntax-error #f "zuviele Operanden" + stx)))) + +(define-syntax (check-property stx) + (unless (memq (syntax-local-context) '(module top-level)) + (raise-syntax-error + #f "`check-property' muss ganz außen stehen" stx)) + (syntax-case stx () + ((_ ?prop) + (stepper-syntax-property + (check-expect-maker stx #'check-property-error #'?prop '() + 'comes-from-check-property) + 'stepper-replace + #'#t)) + (_ (raise-syntax-error #f "`check-property' erwartet einen einzelnen Operanden" + stx)))) + +(define (check-property-error test src-info test-info) + (let ((info (send test-info get-info))) + (send info add-check) + (with-handlers ((exn:fail? + (lambda (e) + (send info property-error e src-info) + (raise e)))) + (call-with-values + (lambda () + (with-handlers + ((exn:assertion-violation? + (lambda (e) + ;; minor kludge to produce comprehensible error message + (if (eq? (exn:assertion-violation-who e) 'coerce->result-generator) + (raise (make-exn:fail (string-append "Wert muß Eigenschaft oder boolesch sein: " + ((error-value->string-handler) + (car (exn:assertion-violation-irritants e)) + 100)) + (exn-continuation-marks e))) + (raise e))))) + (quickcheck-results (test)))) + (lambda (ntest stamps result) + (if (check-result? result) + (begin + (send info property-failed result src-info) + #f) + #t)))))) + +(define (expect v1 v2) + (quickcheck:property () (teach-equal? v1 v2))) + +(define (ensure-real who n val) + (unless (real? val) + (raise + (make-exn:fail:contract + (string->immutable-string + (format "~a Argument ~e zu `~a' keine reelle Zahl." n val who)) + (current-continuation-marks))))) + +(define (expect-within v1 v2 epsilon) + (ensure-real 'expect-within "Drittes" epsilon) + (quickcheck:property () (beginner-equal~? v1 v2 epsilon))) + +(define (expect-range val min max) + (ensure-real 'expect-range "Erstes" val) + (ensure-real 'expect-range "Zweites" min) + (ensure-real 'expect-range "Drittes" max) + (quickcheck:property () + (and (<= min val) + (<= val max)))) + +(define (expect-member-of val . candidates) + (quickcheck:property () + (ormap (lambda (cand) + (teach-equal? val cand)) + candidates))) + +(define property (signature (predicate (lambda (x) + (or (boolean? x) + (property? x)))))) + + +(define-syntax (match stx) + (syntax-parse stx + ((_ ?case:expr (?pattern0 ?body0:expr) (?pattern ?body:expr) ...) + (let () + (define (pattern-variables pat) + (syntax-case pat (empty make-pair list quote) + (empty '()) + (?var (identifier? #'?var) + (if (eq? (syntax->datum #'?var) '_) + '() + (list #'?var))) + (?lit (let ((d (syntax->datum #'?lit))) + (or (string? d) (number? d) (boolean? d))) + '()) + ('?lit '()) + ((make-pair ?pat1 ?pat2) + (append (pattern-variables #'?pat1) (pattern-variables #'?pat2))) + ((list) '()) + ((list ?pat0 ?pat ...) + (apply append (map pattern-variables (syntax->list #'(?pat0 ?pat ...))))) + ((?const ?pat ...) + (apply append (map pattern-variables (syntax->list #'(?pat ...))))))) + (define (check pat) + (let loop ((vars (pattern-variables pat))) + (when (pair? vars) + (let ((var (car vars))) + (when (memf (lambda (other-var) + (free-identifier=? var other-var)) + (cdr vars)) + (raise-syntax-error #f "Variable in match-Zweig kommt doppelt vor" + var)) + (loop (cdr vars)))))) + (for-each check (syntax->list #'(?pattern0 ?pattern ...))) + #'(let* ((val ?case) + (nomatch (lambda () (match val (?pattern ?body) ...)))) + (match-helper val ?pattern0 ?body0 (nomatch))))) + ((_ ?case:expr) + (syntax/loc stx (error 'match "keiner der Zweige passte"))))) + + +(define (list-length=? lis n) + (cond + ((zero? n) (null? lis)) + ((null? lis) #f) + (else + (list-length=? (cdr lis) (- n 1))))) + +(define-syntax (match-helper stx) + (syntax-case stx () + ((_ ?id ?pattern0 ?body0 ?nomatch) + (syntax-case #'?pattern0 (empty make-pair list quote) + (empty + #'(if (null? ?id) + ?body0 + ?nomatch)) + (?var (identifier? #'?var) + (if (eq? (syntax->datum #'?var) '_) ; _ is magic + #'?body0 + #'(let ((?var ?id)) + ?body0))) + (?lit (let ((d (syntax->datum #'?lit))) + (or (string? d) (number? d) (boolean? d))) + #'(if (equal? ?id ?lit) + ?body0 + ?nomatch)) + ('?lit + #'(if (equal? ?id '?lit) + ?body0 + ?nomatch)) + ((make-pair ?pat1 ?pat2) + #'(if (pair? ?id) + (let ((f (first ?id)) + (r (rest ?id))) + (match-helper f ?pat1 + (match-helper r ?pat2 ?body0 ?nomatch) + ?nomatch)) + ?nomatch)) + ((list) + #'(if (null? ?id) + ?body0 + ?nomatch)) + ((list ?pat0 ?pat ...) + (let* ((pats (syntax->list #'(?pat0 ?pat ...))) + (cars (generate-temporaries pats)) + (cdrs (generate-temporaries pats))) + #`(if (and (pair? ?id) + (list-length=? ?id #,(length pats))) + #,(let recur ((ccdr #'?id) + (pats pats) + (cars cars) (cdrs cdrs)) + (if (null? pats) + #'?body0 + #`(let ((#,(car cars) (car #,ccdr)) + (#,(car cdrs) (cdr #,ccdr))) + (match-helper #,(car cars) #,(car pats) + #,(recur (car cdrs) (cdr pats) (cdr cars) (cdr cdrs)) + ?nomatch)))) + ?nomatch))) + ((?const ?pat ...) + (identifier? #'?const) + (let* ((fail (lambda () + (raise-syntax-error #f "Operator in match muss ein Record-Konstruktor sein" + #'?const))) + (v (syntax-local-value #'?const fail))) + (unless (struct-info? v) + (fail)) + + (apply + (lambda (_ _cons pred rev-selectors _mutators ?) + (let* ((pats (syntax->list #'(?pat ...))) + (selectors (reverse rev-selectors)) + (field-ids (generate-temporaries pats))) + (unless (= (length rev-selectors) (length pats)) + (raise-syntax-error #f "Die Anzahl der Felder im match stimmt nicht" stx)) + #`(if (#,pred ?id) + #,(let recur ((pats pats) + (selectors selectors) + (field-ids field-ids)) + (if (null? pats) + #'?body0 + #`(let ((#,(car field-ids) (#,(car selectors) ?id))) + (match-helper #,(car field-ids) #,(car pats) + #,(recur (cdr pats) (cdr selectors) (cdr field-ids)) + ?nomatch)))) + ?nomatch))) + (extract-struct-info v)))))))) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/teachpack/image.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/teachpack/image.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/teachpack/image.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/teachpack/image.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,870 @@ +#lang scheme/base + +#| + +The test suite for this code is in +collects/tests/deinprogramm/image.rkt + +|# + +(require (except-in mred + make-color) + mzlib/class + mrlib/cache-image-snip + mzlib/math + lang/prim + lang/posn + lang/private/imageeq + htdp/error + deinprogramm/signature/signature-syntax + (only-in deinprogramm/DMdA/private/primitives integer natural)) + +(provide ; #### -primitives doesn't work for us + image? + image-width + image-height + + empty-image + + overlay + above + beside + + clip + pad + + rectangle + circle + ellipse + triangle + line + text + + image-inside? + find-image + + image->color-list + color-list->image + + image->alpha-color-list + alpha-color-list->image + + image-color? + make-color + color-red + color-green + color-blue + color? + make-alpha-color + alpha-color-alpha + alpha-color-red + alpha-color-green + alpha-color-blue + alpha-color? + + octet rgb-color alpha-rgb-color mode image image-color + h-place v-place h-mode v-mode) + +;; ---------------------------------------- + +(define (color-list? l) + (and (list? l) (andmap image-color? l))) +(define (alpha-color-list? l) + (and (list? l) (andmap alpha-color? l))) + +(define-struct color (red green blue) #:inspector (make-inspector)) +(define-struct alpha-color (alpha red green blue) #:inspector (make-inspector)) + +;; ---------------------------------------- + +(define (check name p? v desc arg-posn) (check-arg name (p? v) desc arg-posn v)) + +(define (check-coordinate name val arg-posn) (check name finite-real? val "real" arg-posn)) +(define (check-integer-coordinate name val arg-posn) (check name nii? val "integer" arg-posn)) +(define (check-size name val arg-posn) (check name pos-real? val "positive real" arg-posn)) +(define (check-posi-size name val arg-posn) (check name pos-integer? val "positive integer" arg-posn)) +(define (check-size/0 name val arg-posn) (check name nn-real? val "non-negative real" arg-posn)) +(define (check-h-place name val arg-posn) + (check name h-place? val + "non-negative exact integer or horizontal alignment position" + arg-posn)) +(define (check-v-place name val arg-posn) + (check name v-place? val + "non-negative exact integer or vertical alignment position" + arg-posn)) +(define (check-image name val arg-posn) (check name image? val "image" arg-posn)) +(define (check-image-color name val arg-posn) + (let ([simple-check (lambda (x) (or (string? x) (symbol? x) (color? x)))]) + (check name simple-check val "image-color" arg-posn) + (unless (image-color? val) + (error name "~e is not a valid color name" val)))) +(define (check-mode name val arg-posn) (check name mode? val mode-str arg-posn)) + +(define (pos-real? i) (and (real? i) (positive? i))) +(define (pos-integer? i) (and (integer? i) (positive? i))) +(define (nn-real? i) (and (real? i) (or (zero? i) (positive? i)))) +(define (nii? x) (and (integer? x) (not (= x +inf.0)) (not (= x -inf.0)))) + +(define (finite-real? x) (and (real? x) (not (= x +inf.0)) (not (= x -inf.0)))) + +(define (check-sizes who w h) + (unless (and (< 0 w 10000) (< 0 h 10000)) + (error (format "cannot make ~a x ~a image" w h)))) + +(define (mode? x) + (member x '(solid "solid" outline "outline"))) + +(define mode-str "'solid \"solid\" 'outline or \"outline\"") + +(define (mode->brush-symbol m) + (cond + [(member m '(solid "solid")) + 'solid] + [(member m '(outline "outline")) + 'transparent])) + +(define (mode->pen-symbol m) + (cond + [(member m '(solid "solid")) 'transparent] + [(member m '(outline "outline")) 'solid])) + +(define (h-place? x) + (or (nn-real? x) + (h-mode? x))) + +(define (v-place? x) + (or (nn-real? x) + (v-mode? x))) + +(define (h-mode? x) + (member x '(left "left" right "right" "center"))) + +(define (v-mode? x) + (member x '(top "top" bottom "bottom" center "center"))) + +(define (make-color% c) + (cond + [(string? c) (send the-color-database find-color c)] + [(symbol? c) (send the-color-database find-color (symbol->string c))] + [(color? c) (make-object color% + (color-red c) + (color-green c) + (color-blue c))] + [else #f])) + +(define (image-color? c) + (cond + [(color? c) #t] + [(string? c) (and (send the-color-database find-color c) #t)] + [(symbol? c) (and (send the-color-database find-color (symbol->string c)) #t)] + [else #f])) + +(define (image-width a) + (check-image 'image-width a "first") + (let-values ([(w h) (snip-size a)]) + (inexact->exact (ceiling w)))) + +(define (image-height a) + (check-image 'image-height a "first") + (let-values ([(w h) (snip-size a)]) + (inexact->exact (ceiling h)))) + +(define (overlay a b h-place v-place) + (overlay-helper 'overlay a b h-place v-place)) + +(define (overlay-helper name a b h-place v-place) + (check-image name a "first") + (check-image name b "second") + (check-h-place name h-place "third") + (check-v-place name v-place "fourth") + (let ((dx (h-place->delta-x h-place a b)) + (dy (v-place->delta-y v-place a b))) + (real-overlay name + a + (inexact->exact (floor dx)) + (inexact->exact (floor dy)) + b))) + +(define (h-place->delta-x h-place a b) + (cond + ((real? h-place) (inexact->exact (floor h-place))) + ((member h-place '(left "left")) 0) + ((member h-place '(right "right")) + (- (image-width a) (image-width b))) + ((member h-place '(center "center")) + (- (quotient (image-width a) 2) + (quotient (image-width b) 2))))) + +(define (v-place->delta-y v-place a b) + (cond + ((real? v-place) (inexact->exact (floor v-place))) + ((member v-place '(top "top")) 0) + ((member v-place '(bottom "bottom")) + (- (image-height a) (image-height b))) + ((member v-place '(center "center")) + (- (quotient (image-height a) 2) + (quotient (image-height b) 2))))) + +(define (above a b h-mode) + (overlay-helper 'above a b h-mode (image-height a))) + +(define (beside a b v-mode) + (overlay-helper 'beside a b (image-width a) v-mode)) + +(define (real-overlay name raw-a delta-x delta-y raw-b) + (let ([a (coerce-to-cache-image-snip raw-a)] + [b (coerce-to-cache-image-snip raw-b)]) + (let-values ([(a-w a-h) (snip-size a)] + [(b-w b-h) (snip-size b)]) + (let* ([left (min 0 delta-x)] + [top (min 0 delta-y)] + [right (max (+ delta-x b-w) a-w)] + [bottom (max (+ delta-y b-h) a-h)] + [new-w (inexact->exact (ceiling (- right left)))] + [new-h (inexact->exact (ceiling (- bottom top)))] + [a-dx (inexact->exact (round (- left)))] + [a-dy (inexact->exact (round (- top)))] + [b-dx (inexact->exact (round (- delta-x left)))] + [b-dy (inexact->exact (round (- delta-y top)))] + [combine (lambda (a-f b-f) + (lambda (dc dx dy) + (a-f dc (+ dx a-dx) (+ dy a-dy)) + (b-f dc (+ dx b-dx) (+ dy b-dy))))]) + (check-sizes name new-w new-h) + (new cache-image-snip% + [dc-proc (combine (send a get-dc-proc) + (send b get-dc-proc))] + [argb-proc (combine (send a get-argb-proc) + (send b get-argb-proc))] + [width new-w] + [height new-h] + ;; match what image=? expects, so we don't get false negatives + [px (floor (/ new-w 2))] + [py (floor (/ new-h 2))]))))) + +;; ------------------------------------------------------------ + +(define (clip raw-img delta-w delta-h width height) + (check-image 'clip raw-img "first") + (check-size/0 'clip delta-w "second") + (check-size/0 'clip delta-h "third") + (check-size/0 'clip width "fourth") + (check-size/0 'clip height "fifth") + (let ((delta-w (inexact->exact (floor delta-w))) + (delta-h (inexact->exact (floor delta-h))) + (width (inexact->exact (floor width))) + (height (inexact->exact (floor height)))) + (let ([img (coerce-to-cache-image-snip raw-img)]) + (let-values ([(i-width i-height) (send img get-size)]) + (let* ([dc-proc (send img get-dc-proc)] + [argb-proc (send img get-argb-proc)]) + (new cache-image-snip% + [dc-proc (lambda (dc dx dy) + (let ([clip (send dc get-clipping-region)] + [rgn (make-object region% dc)]) + (send rgn set-rectangle dx dy width height) + (when clip + (send rgn intersect clip)) + (send dc set-clipping-region rgn) + (dc-proc dc (- dx delta-w) (- dy delta-h)) + (send dc set-clipping-region clip)))] + [argb-proc (lambda (argb dx dy) (argb-proc argb (- dx delta-w) (- dy delta-h)))] + [width width] + [height height] + ;; match what image=? expects, so we don't get false negatives + [px (floor (/ width 2))] [py (floor (/ height 2))])))))) + +(define (pad raw-img left right top bottom) + (check-image 'pad raw-img "first") + (check-size/0 'pad left "second") + (check-size/0 'pad right "third") + (check-size/0 'pad top "fourth") + (check-size/0 'pad bottom "fifth") + (let ((left (inexact->exact (floor left))) + (right (inexact->exact (floor right))) + (top (inexact->exact (floor top))) + (bottom (inexact->exact (floor bottom)))) + (let ([img (coerce-to-cache-image-snip raw-img)]) + (let-values ([(i-width i-height) (send img get-size)]) + (let ((width (+ left i-width right)) + (height (+ top i-height bottom))) + (let* ([dc-proc (send img get-dc-proc)] + [argb-proc (send img get-argb-proc)]) + (new cache-image-snip% + [dc-proc (lambda (dc dx dy) + (let ([clip (send dc get-clipping-region)] + [rgn (make-object region% dc)]) + (send rgn set-rectangle dx dy width height) + (when clip + (send rgn intersect clip)) + (send dc set-clipping-region rgn) + (dc-proc dc (+ dx left) (+ dy top)) + (send dc set-clipping-region clip)))] + [argb-proc (lambda (argb dx dy) (argb-proc argb (+ dx left) (+ dy top)))] + [width width] + [height height] + ;; match what image=? expects, so we don't get false negatives + [px (floor (/ width 2))] [py (floor (/ height 2))]))))))) + + +;; ------------------------------------------------------------ + +;; test what happens when the line moves out of the box. +(define (line width height pre-x1 pre-y1 pre-x2 pre-y2 color-in) + (check-size/0 'line width "first") + (check-size/0 'line height "second") + (check-coordinate 'line pre-x1 "third") + (check-coordinate 'line pre-y1 "fourth") + (check-coordinate 'line pre-x2 "fifth") + (check-coordinate 'line pre-y2 "sixth") + (check-image-color 'line color-in "seventh") + (let ((width (inexact->exact (floor width))) + (height (inexact->exact (floor height)))) + (let-values ([(x1 y1 x2 y2) + (if (<= pre-x1 pre-x2) + (values pre-x1 pre-y1 pre-x2 pre-y2) + (values pre-x2 pre-y2 pre-x1 pre-y1))]) + (define do-draw + (lambda (dc dx dy) + (let ([clip (send dc get-clipping-region)] + [rgn (make-object region% dc)]) + (send rgn set-rectangle dx dy width height) + (when clip + (send rgn intersect clip)) + (send dc set-clipping-region rgn) + (send dc draw-line + (+ x1 dx) (+ y1 dy) (+ x2 dx) (+ y2 dy)) + (send dc set-clipping-region clip)))) + + (let ([draw-proc + (make-color-wrapper color-in 'transparent 'solid do-draw)] + [mask-proc + (make-color-wrapper 'black 'transparent 'solid do-draw)]) + (make-simple-cache-image-snip width height draw-proc mask-proc))))) + +(define (text str size color-in) + (check 'text string? str "string" "first") + (check 'text (lambda (x) (and (integer? x) (<= 1 x 255))) size "integer between 1 and 255" "second") + (check-image-color 'text color-in "third") + (cond + [(string=? str "") + (let-values ([(tw th) (get-text-size size "dummyX")]) + (rectangle 0 th 'solid 'black))] + [else + (let ([color (make-color% color-in)]) + (let-values ([(tw th) (get-text-size size str)]) + (let ([draw-proc + (lambda (txt-color mode dc dx dy) + (let ([old-mode (send dc get-text-mode)] + [old-fore (send dc get-text-foreground)] + [old-font (send dc get-font)]) + (send dc set-text-mode mode) + (send dc set-text-foreground txt-color) + (send dc set-font (get-font size)) + (send dc draw-text str dx dy) + (send dc set-text-mode old-mode) + (send dc set-text-foreground old-fore) + (send dc set-font old-font)))]) + (new cache-image-snip% + [dc-proc (lambda (dc dx dy) (draw-proc color 'transparent dc dx dy))] + [argb-proc + (lambda (argb dx dy) + (let ([bm-color + (build-bitmap + (lambda (dc) + (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) + (send dc set-brush (send the-brush-list find-or-create-brush color 'solid)) + (send dc draw-rectangle 0 0 tw th)) + tw + th)] + [bm-mask + (build-bitmap + (lambda (dc) + (draw-proc + (send the-color-database find-color "black") + 'solid dc 0 0)) + tw + th)]) + (overlay-bitmap argb dx dy bm-color bm-mask)))] + [width tw] + [height th] + ;; match what image=? expects, so we don't get false negatives + [px (floor (/ tw 2))] [py (floor (/ th 2))]))))])) + +(define cached-bdc-for-text-size (make-thread-cell #f)) +(define (get-text-size size string) + (unless (thread-cell-ref cached-bdc-for-text-size) + (let* ([bm (make-object bitmap% 1 1)] + [dc (make-object bitmap-dc% bm)]) + (thread-cell-set! cached-bdc-for-text-size dc))) + (let ([dc (thread-cell-ref cached-bdc-for-text-size)]) + (let-values ([(w h _1 _2) (send dc get-text-extent string (get-font size))]) + (values (inexact->exact (ceiling w)) + (inexact->exact (ceiling h)))))) + +(define (get-font size) + (send the-font-list find-or-create-font size + 'default 'normal 'normal #f + (case (system-type) + [(macosx) 'partly-smoothed] + [else 'smoothed]))) + +(define (a-rect/circ do-draw w h color brush pen) + (let* ([dc-proc (make-color-wrapper color brush pen do-draw)] + [mask-proc (make-color-wrapper 'black brush pen do-draw)]) + (make-simple-cache-image-snip w h dc-proc mask-proc))) + +(define (rectangle w h mode color) + (check-size/0 'rectangle w "first") + (check-size/0 'rectangle h "second") + (check-mode 'rectangle mode "third") + (check-image-color 'rectangle color "fourth") + (let ((w (inexact->exact (floor w))) + (h (inexact->exact (floor h)))) + (a-rect/circ (lambda (dc dx dy) (send dc draw-rectangle dx dy w h)) + w h color (mode->brush-symbol mode) (mode->pen-symbol mode)))) + +(define (ellipse w h mode color) + (check-size/0 'ellipse w "first") + (check-size/0 'ellipse h "second") + (check-mode 'ellipse mode "third") + (check-image-color 'ellipse color "fourth") + (let ((w (inexact->exact (floor w))) + (h (inexact->exact (floor h)))) + (a-rect/circ (lambda (dc dx dy) (send dc draw-ellipse dx dy w h)) + w h color (mode->brush-symbol mode) (mode->pen-symbol mode)))) + +(define (circle r mode color) + (check-size/0 'circle r "first") + (check-mode 'circle mode "second") + (check-image-color 'circle color "third") + (let ((r (inexact->exact (floor r)))) + (a-rect/circ (lambda (dc dx dy) (send dc draw-ellipse dx dy (* 2 r) (* 2 r))) + (* 2 r) (* 2 r) color (mode->brush-symbol mode) (mode->pen-symbol mode)))) + +(define (triangle size mode color) + (check 'triangle + (lambda (x) (and (real? x) (< 2 x 10000))) + size + "positive real number bigger than 2" + "first") + (check-mode 'triangle mode "second") + (check-image-color 'triangle color "third") + (let* ([size (inexact->exact (floor size))] + [right (- size 1)] + [bottom (inexact->exact (ceiling (* size (sin (* 2/3 pi)))))] + [points (list (make-object point% 0 bottom) + (make-object point% right bottom) + (make-object point% (/ size 2) 0))]) + (let ([draw (make-color-wrapper + color (mode->brush-symbol mode) 'solid + (lambda (dc dx dy) + (send dc draw-polygon points dx dy)))] + [mask-draw (make-color-wrapper + 'black (mode->brush-symbol mode) 'solid + (lambda (dc dx dy) + (send dc draw-polygon points dx dy)))] + [w size] + [h (+ bottom 1)]) + (make-simple-cache-image-snip w h draw mask-draw)))) + +(define (make-simple-cache-image-snip w h dc-proc mask-proc) + (let ([w (inexact->exact (ceiling w))] + [h (inexact->exact (ceiling h))]) + (let ([argb-proc + (if (or (zero? w) (zero? h)) + void + (lambda (argb-vector dx dy) + (let ([c-bm (build-bitmap (lambda (dc) (dc-proc dc 0 0)) w h)] + [m-bm (build-bitmap (lambda (dc) (mask-proc dc 0 0)) w h)]) + (overlay-bitmap argb-vector dx dy c-bm m-bm))))]) + (new cache-image-snip% + [dc-proc dc-proc] + [argb-proc argb-proc] + [width w] + [height h] + ;; match what image=? expects, so we don't get false negatives + [px (floor (/ w 2))] [py (floor (/ h 2))])))) + +(define (make-color-wrapper color-in brush pen rest) + (let ([color (make-color% color-in)]) + (lambda (dc dx dy) + (let ([old-brush (send dc get-brush)] + [old-pen (send dc get-pen)]) + (send dc set-brush (send the-brush-list find-or-create-brush color brush)) + (send dc set-pen (send the-pen-list find-or-create-pen color 1 pen)) + (rest dc dx dy) + (send dc set-pen old-pen) + (send dc set-brush old-brush))))) + +;; ------------------------------------------------------------ + +(define (image-inside? i a) + (and (locate-image 'image-inside? + (coerce-to-cache-image-snip i) + (coerce-to-cache-image-snip a)) + #t)) + +(define (find-image i a) + (or (locate-image 'find-image + (coerce-to-cache-image-snip i) + (coerce-to-cache-image-snip a)) + (error 'find-image + "the second image does not appear within the first image"))) + +(define (locate-image who i a) + (check-image who i "first") + (check-image who a "second") + (let-values ([(iw ih) (snip-size i)] + [(aw ah) (snip-size a)]) + (and (iw . >= . aw) + (ih . >= . ah) + (let ([i-argb-vector (argb-vector (send i get-argb))] + [a-argb-vector (argb-vector (send a get-argb))]) + (let ([al (let loop ([offset 0]) + (cond + [(= offset (* ah aw 4)) null] + [else (cons (subvector a-argb-vector offset (+ offset (* 4 aw))) + (loop (+ offset (* 4 aw))))]))]) + (let yloop ([dy 0]) + (and (dy . <= . (- ih ah)) + (let xloop ([dx 0]) + (if (dx . <= . (- iw aw)) + (if (let loop ([al al][dd 0]) + (or (null? al) + (and (first-in-second? + i-argb-vector + (car al) + (* 4 (+ (* (+ dy dd) iw) dx))) + (loop (cdr al) (add1 dd))))) + (make-posn dx dy) + (xloop (add1 dx))) + (yloop (add1 dy))))))))))) + +(define (subvector orig i j) + (let ([v (make-vector (- j i) #f)]) + (let loop ([x i]) + (when (< x j) + (vector-set! v (- x i) (vector-ref orig x)) + (loop (+ x 1)))) + v)) +#| +(initial inequalities thanks to Matthew (thanks!!)) + +We know that, for a combination: + m3 = (m1+m2-m1*m2) and + b3 = (m1*b1*(1-m2) + m2*b2)/m3 + +So, we need to figure out what m1 & m2 might have been, +given the other values. + +Check m3: + + m3 = m2 when m1 = 0 + m3 = 1 when m1 = 1 + + [deriv of m3 with respect to m1 = 1 - m2, which is positive] + + so check that m3 is between m2 and 1 + +Then check m3*b3: + + b3*m3 = m2*b2 when m1 = 0 or b1 = 0 + b3*m3 = (1 - m2) + m2*b2 when m1 = b1 = 1 + + [deriv with respect to m1 is b1*(1-m2), which is positive] + [deriv with respect to b1 is m1*(1-m2), which is positive] + + So check that m3*b3 is between m2*b2 and (1 - m2) + m2*b2 + +This is all in alphas from 0 to 1 and needs to be from 255 to 0. +Converting (but using the same names) for the alpha test, we get: + +(<= (- 1 (/ m2 255)) + (- 1 (/ m3 255)) + 1) + +sub1 to each: + +(<= (- (/ m2 255)) + (- (/ m3 255)) + 0) + +mult by 255: + +(<= (- m2) + (- m3) + 0) + +negate and flip ineq: + + +(>= m2 m3 0) + +flip ineq back: + +(<= 0 m3 m2) + + +Here's the original scheme expression for the second check: + +(<= (* m2 b2) + (* m3 b3) + (+ (- 1 m2) (* m2 b2)) + +converting from the computer's coordinates, we get: + + +(<= (* (- 1 (/ m2 255)) (- 1 (/ b2 255))) + (* (- 1 (/ m3 255)) (- 1 (/ b3 255))) + (+ (- 1 (- 1 (/ m2 255))) + (* (- 1 (/ m2 255)) (- 1 (/ b2 255))))) + +;; multiplying out the binomials: + +(<= (+ 1 + (- (/ m2 255)) + (- (/ b2 255)) + (/ (* m2 b2) (* 255 255))) + (+ 1 + (- (/ m3 255)) + (- (/ b3 255)) + (/ (* m3 b3) (* 255 255))) + (+ (- 1 (- 1 (/ m2 255))) + (+ 1 + (- (/ m2 255)) + (- (/ b2 255)) + (/ (* m2 b2) (* 255 255))))) + +;; simplifying the last term + +(<= (+ 1 + (- (/ m2 255)) + (- (/ b2 255)) + (/ (* m2 b2) (* 255 255))) + (+ 1 + (- (/ m3 255)) + (- (/ b3 255)) + (/ (* m3 b3) (* 255 255))) + (+ 1 + (- (/ b2 255)) + (/ (* m2 b2) (* 255 255)))) + +;; multiply thru by 255: + +(<= (+ 255 + (- m2) + (- b2) + (* m2 b2 1/255)) + (+ 255 + (- m3) + (- b3) + (* m3 b3 1/255)) + (+ 255 + (- b2) + (* m2 b2 1/255))) + +;; subtract out 255 from each: + +(<= (+ (- m2) + (- b2) + (* m2 b2 1/255)) + (+ (- m3) + (- b3) + (* m3 b3 1/255)) + (+ (- b2) + (* m2 b2 1/255))) + +;; negate them all, and reverse the inequality + +(>= (+ m2 b2 (* m2 b2 -1/255)) + (+ m3 b3 (* m3 b3 -1/255)) + (+ b2 (* m2 b2 -1/255))) + +;; aka + +(<= (+ b2 (* m2 b2 -1/255)) + (+ m3 b3 (* m3 b3 -1/255)) + (+ m2 b2 (* m2 b2 -1/255))) + +|# + +;; in the above, m3 & b3 come from iv +;; and m2 & b2 come from av +(define (first-in-second? iv av xd) + (let loop ([i (vector-length av)]) + (or (zero? i) + (let ([a (- i 4)] + [r (- i 3)] + [g (- i 2)] + [b (- i 1)]) + (let* ([m2 (vector-ref av a)] + [m3 (vector-ref iv (+ xd a))] + [test + (lambda (b2 b3) + (<= (+ b2 (* m2 b2 -1/255)) + (+ m3 b3 (* m3 b3 -1/255)) + (+ m2 b2 (* m2 b2 -1/255))))]) + (and (<= 0 m3 m2) + (test (vector-ref av r) (vector-ref iv (+ xd r))) + (test (vector-ref av g) (vector-ref iv (+ xd g))) + (test (vector-ref av b) (vector-ref iv (+ xd b))) + (loop (- i 4)))))))) + +;; ---------------------------------------- + +(define (image->color-list i-raw) + (check-image 'image->color-list i-raw "first") + (let* ([cis (coerce-to-cache-image-snip i-raw)] + [i (send cis get-bitmap)]) + (cond + [(not i) '()] + [else + (let* ([iw (send i get-width)] + [ih (send i get-height)] + [new-bitmap (make-object bitmap% iw ih)] + [bdc (make-object bitmap-dc% new-bitmap)]) + (send bdc clear) + (send bdc draw-bitmap i 0 0 'solid + (send the-color-database find-color "black") + (send i get-loaded-mask)) + (let ([is (make-bytes (* 4 iw ih))] + [cols (make-vector (* iw ih))]) + (send bdc get-argb-pixels 0 0 iw ih is) + (let yloop ([y 0][pos 0]) + (unless (= y ih) + (let xloop ([x 0][pos pos]) + (if (= x iw) + (yloop (add1 y) pos) + (begin + (vector-set! cols (+ x (* y iw)) + (make-color (bytes-ref is (+ 1 pos)) + (bytes-ref is (+ 2 pos)) + (bytes-ref is (+ 3 pos)))) + (xloop (add1 x) (+ pos 4))))))) + (send bdc set-bitmap #f) + (vector->list cols)))]))) + +(define (image->alpha-color-list i) + (check-image 'image->alpha-color-list i "first") + (let* ([argb (cond + [(is-a? i image-snip%) + (send (coerce-to-cache-image-snip i) get-argb)] + [(is-a? i cache-image-snip%) (send i get-argb)])] + [v (argb-vector argb)]) + (let loop ([i (vector-length v)] + [a null]) + (cond + [(zero? i) a] + [else (loop (- i 4) + (cons (make-alpha-color + (vector-ref v (- i 4)) + (vector-ref v (- i 3)) + (vector-ref v (- i 2)) + (vector-ref v (- i 1))) + a))])))) + +(define (color-list->image cl in-w in-h) + (check 'color-list->image color-list? cl "list-of-colors" "first") + (check-size/0 'color-list->image in-w "second") + (check-size/0 'color-list->image in-h "third") + (let ([w (inexact->exact in-w)] + [h (inexact->exact in-h)]) + (let ([px (floor (/ w 2))] [py (floor (/ h 2))]) + + (unless (= (* w h) (length cl)) + (error 'color-list->image + "given width times given height is ~a, but the given color list has ~a items" + (* w h) + (length cl))) + + (cond + [(or (equal? w 0) (equal? h 0)) + (rectangle w h 'solid 'black)] + [else + (unless (and (< 0 w 10000) (< 0 h 10000)) + (error 'color-list->image "cannot make ~a x ~a image" w h)) + + (let* ([bm (make-object bitmap% w h)] + [mask-bm (make-object bitmap% w h)] + [dc (make-object bitmap-dc% bm)] + [mask-dc (make-object bitmap-dc% mask-bm)]) + (unless (send bm ok?) + (error (format "cannot make ~a x ~a image" w h))) + (let ([is (make-bytes (* 4 w h) 0)] + [mask-is (make-bytes (* 4 w h) 0)] + [cols (list->vector (map (lambda (x) + (or (make-color% x) + (error 'color-list->image "color ~e is unknown" x))) + cl))]) + (let yloop ([y 0][pos 0]) + (unless (= y h) + (let xloop ([x 0][pos pos]) + (if (= x w) + (yloop (add1 y) pos) + (let* ([col (vector-ref cols (+ x (* y w)))] + [r (pk (send col red))] + [g (pk (send col green))] + [b (pk (send col blue))]) + (bytes-set! is (+ 1 pos) r) + (bytes-set! is (+ 2 pos) g) + (bytes-set! is (+ 3 pos) b) + (when (= 255 r g b) + (bytes-set! mask-is (+ 1 pos) 255) + (bytes-set! mask-is (+ 2 pos) 255) + (bytes-set! mask-is (+ 3 pos) 255)) + (xloop (add1 x) (+ pos 4))))))) + (send dc set-argb-pixels 0 0 w h is) + (send mask-dc set-argb-pixels 0 0 w h mask-is)) + (send dc set-bitmap #f) + (send mask-dc set-bitmap #f) + (bitmaps->cache-image-snip bm mask-bm px py))])))) + +(define (pk col) (min 255 (max 0 col))) + +(define (alpha-color-list->image cl in-w in-h) + (check 'alpha-color-list->image alpha-color-list? cl "list-of-alpha-colors" "first") + (check-size/0 'alpha-color-list->image in-w "second") + (check-size/0 'alpha-color-list->image in-h "third") + (let ([w (inexact->exact in-w)] + [h (inexact->exact in-h)]) + (let ([px (floor (/ w 2))] [py (floor (/ h 2))]) + (unless (= (* w h) (length cl)) + (error 'alpha-color-list->image + "given width times given height is ~a, but the given color list has ~a items" + (* w h) (length cl))) + (cond + [(or (equal? w 0) (equal? h 0)) + (rectangle w h 'solid 'black)] + [else + (unless (and (< 0 w 10000) (< 0 h 10000)) + (error 'alpha-color-list->image format "cannot make ~a x ~a image" w h)) + (let ([index-list (alpha-colors->ent-list cl)]) + (argb->cache-image-snip (make-argb (list->vector index-list) w h) px py))])))) + +;; alpha-colors->ent-list : (listof alpha-color) -> (listof number) +(define (alpha-colors->ent-list cl) + (let loop ([cl cl]) + (cond + [(null? cl) null] + [else + (let ([ac (car cl)]) + (list* (alpha-color-alpha ac) + (alpha-color-red ac) + (alpha-color-green ac) + (alpha-color-blue ac) + (loop (cdr cl))))]))) + +(define empty-image + (make-simple-cache-image-snip 0 0 void void)) + +(define octet (signature (combined natural (predicate (lambda (n) (<= n 255)))))) +(define rgb-color (signature (predicate color?))) +(define alpha-rgb-color (signature (predicate alpha-color?))) +(define mode (signature (one-of "solid" "outline"))) +(define image (signature (predicate image?))) +(define image-color (signature (predicate image-color?))) +(define h-place (signature (mixed integer (one-of "left" "right" "center")))) +(define v-place (signature (mixed integer (one-of "top" "bottom" "center")))) +(define h-mode (signature (one-of "left" "right" "center"))) +(define v-mode (signature (one-of "top" "bottom" "center"))) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/teachpack/line3d.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/teachpack/line3d.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/teachpack/line3d.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/teachpack/line3d.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,60 @@ +(module line3d mzscheme + (require "world.rkt" + deinprogramm/DMdA/define-record-procedures) + (require (only deinprogramm/DMdA-vanilla + empty make-pair empty? + first rest)) + (provide make-vec3 + vec3-x + vec3-y + vec3-z + add-vec3 + sub-vec3 + mult-vec3 + div-vec3 + dotproduct-vec3 + normquad-vec3 + norm-vec3 + normalize-vec3 + crossproduct-vec3 + make-vec4 + vec4-x + vec4-y + vec4-z + vec4-w + add-vec4 + sub-vec4 + mult-vec4 + div-vec4 + dotproduct-vec4 + normquad-vec4 + norm-vec4 + normalize-vec4 + expand-vec3 + make-matrix4x4 + create-matrix4x4 + transpose-matrix4x4 + multiply-matrix-vec4 + transform-vec3 + multiply-matrix + create-translation-matrix + create-rotation-x-matrix + create-rotation-y-matrix + create-rotation-z-matrix + print-vec4 + print-matrix4x4 + create-lookat-matrix + create-projection-matrix + create-viewport-matrix + create-camera-matrix + make-line3d + line3d-a + line3d-b + line3d-color + create-box + transform-primitive-list + render-scene + ) + + (require mzlib/include) + (include "line3d.scm")) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/teachpack/line3d.scm racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/teachpack/line3d.scm --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/teachpack/line3d.scm 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/teachpack/line3d.scm 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,510 @@ +;; ############################################### +;; ############################################### +;; +;; Mini-3D-Engine +;; +;; 3D-Object are represented with line primitives +;; +;; Martin Bokeloh, Sebastian Veith +;; ############################################### +;; ############################################### + + +;; ----------------------------------- +;; some linear algebra tools +;; ----------------------------------- + +;; 3D-vector +(define-record-procedures vec3 + make-vec3 vec3? + (vec3-x + vec3-y + vec3-z)) + +;; return a+b +;; add-vec3 : vec3 vec3 -> vec3 +(define add-vec3 + (lambda (a b) + (make-vec3 + (+ (vec3-x a) (vec3-x b)) + (+ (vec3-y a) (vec3-y b)) + (+ (vec3-z a) (vec3-z b))))) + +;; return a-b +;; sub-vec3 : vec3 vec3 -> vec3 +(define sub-vec3 + (lambda (a b) + (make-vec3 + (- (vec3-x a) (vec3-x b)) + (- (vec3-y a) (vec3-y b)) + (- (vec3-z a) (vec3-z b))))) + +;; return v*s +;; mult-vec3 : vec3 number -> vec3 +(define mult-vec3 + (lambda (v s) + (make-vec3 + (* (vec3-x v) s) + (* (vec3-y v) s) + (* (vec3-z v) s)))) + +;; return v/s +;; div-vec3 : vec3 number -> vec3 +(define div-vec3 + (lambda (v s) + (mult-vec3 v (/ 1 s)))) + +;; return a*b +;; dotproduct-vec3 : vec3 vec3 -> Number +(define dotproduct-vec3 + (lambda (a b) + (+ + (* (vec3-x a) (vec3-x b)) + (* (vec3-y a) (vec3-y b)) + (* (vec3-z a) (vec3-z b))))) + +;; compute quadratic euclidian norm +;; normquad-vec3 : vec3 -> Number +(define normquad-vec3 + (lambda (a) + (+ + (* (vec3-x a) (vec3-x a)) + (* (vec3-y a) (vec3-y a)) + (* (vec3-z a) (vec3-z a))))) + +;; compute euclidian norm +;; norm-vec3 : vec3 -> Number +(define norm-vec3 + (lambda (a) + (sqrt (normquad-vec3 a)))) + +;; normalize vector +;; normalize-vec3 : vec3 -> vec3 +(define normalize-vec3 + (lambda (a) + (div-vec3 a (norm-vec3 a)))) + +;; cross product (computes a vector perpendicular to both input vectors) +;; crossproduct-vec3 : vec3 vec3 -> vec3 +(define crossproduct-vec3 + (lambda (a b) + (make-vec3 + (- (* (vec3-y a) (vec3-z b)) (* (vec3-z a) (vec3-y b))) + (- (* (vec3-z a) (vec3-x b)) (* (vec3-x a) (vec3-z b))) + (- (* (vec3-x a) (vec3-y b)) (* (vec3-y a) (vec3-x b)))))) + +;; 4D-vector +(define-record-procedures vec4 + make-vec4 vec4? + (vec4-x + vec4-y + vec4-z + vec4-w)) + +;; expands a 3d-vector to a 4d-vector (v,s) +;; expand-vec3 : vec3 number -> vec4 +(define expand-vec3 + (lambda (v s) + (make-vec4 (vec3-x v) (vec3-y v) (vec3-z v) s))) + +;; return a+b +;; add-vec4 : vec4 vec4 -> vec4 +(define add-vec4 + (lambda (a b) + (make-vec4 + (+ (vec4-x a) (vec4-x b)) + (+ (vec4-y a) (vec4-y b)) + (+ (vec4-z a) (vec4-z b)) + (+ (vec4-w a) (vec4-w b))))) + +;; return a-b +;; sub-vec4 : vec4 vec4 -> vec4 +(define sub-vec4 + (lambda (a b) + (make-vec4 + (- (vec4-x a) (vec4-x b)) + (- (vec4-y a) (vec4-y b)) + (- (vec4-z a) (vec4-z b)) + (- (vec4-w a) (vec4-w b))))) + +;; return v*s +;; mult-vec4 : vec4 number -> vec4 +(define mult-vec4 + (lambda (v s) + (make-vec4 + (* (vec4-x v) s) + (* (vec4-y v) s) + (* (vec4-z v) s) + (* (vec4-w v) s)))) + +;; return v/s +;; div-vec4 : vec4 number -> vec4 +(define div-vec4 + (lambda (v s) + (mult-vec4 v (/ 1 s)))) + +;; return a*b +;; dotproduct-vec4 : vec4 vec4 -> Number +(define dotproduct-vec4 + (lambda (a b) + (+ + (* (vec4-x a) (vec4-x b)) + (* (vec4-y a) (vec4-y b)) + (* (vec4-z a) (vec4-z b)) + (* (vec4-w a) (vec4-w b))))) + +;; compute quadratic euclidian norm +;; normquad-vec4 : vec4 -> Number +(define normquad-vec4 + (lambda (a) + (+ + (* (vec4-x a) (vec4-x a)) + (* (vec4-y a) (vec4-y a)) + (* (vec4-z a) (vec4-z a)) + (* (vec4-w a) (vec4-w a))))) + +;; compute euclidian norm +;; norm-vec4 : vec4 -> Number +(define norm-vec4 + (lambda (a) + (sqrt (normquad-vec4 a)))) + +;; normalize vector +;; normalize-vec4 : vec4 -> vec4 +(define normalize-vec4 + (lambda (a) + (/ a (norm-vec4 a)))) + +;; 4x4 matrix (implemented with 4 row vectors; vec4) +(define-record-procedures matrix4x4 + make-matrix4x4 matrix4x4? + (matrix4x4-1 + matrix4x4-2 + matrix4x4-3 + matrix4x4-4)) + +;; create 4x4 from 4 3d-vectors +;; create-matrix4x4 : vec3 vec3 vec3 vec3 -> matrix4x4 +(define create-matrix4x4 + (lambda (v1 v2 v3 v4) + (make-matrix4x4 + (expand-vec3 v1 0 ) + (expand-vec3 v2 0 ) + (expand-vec3 v3 0 ) + (expand-vec3 v4 1 )))) + +;; return a^T +;; transpose-matrix4x4 : matrix4x4 -> matrix4x4 +(define transpose-matrix4x4 + (lambda (a) + (make-matrix4x4 + (make-vec4 (vec4-x (matrix4x4-1 a)) + (vec4-x (matrix4x4-2 a)) + (vec4-x (matrix4x4-3 a)) + (vec4-x (matrix4x4-4 a))) + (make-vec4 (vec4-y (matrix4x4-1 a)) + (vec4-y (matrix4x4-2 a)) + (vec4-y (matrix4x4-3 a)) + (vec4-y (matrix4x4-4 a))) + (make-vec4 (vec4-z (matrix4x4-1 a)) + (vec4-z (matrix4x4-2 a)) + (vec4-z (matrix4x4-3 a)) + (vec4-z (matrix4x4-4 a))) + (make-vec4 (vec4-w (matrix4x4-1 a)) + (vec4-w (matrix4x4-2 a)) + (vec4-w (matrix4x4-3 a)) + (vec4-w (matrix4x4-4 a)))))) + +;; multiply 4x4 matrix with vec4 +;; multiply-matrix-vec4 : matrix4x4 vec4 -> vec4 +(define multiply-matrix-vec4 + (lambda (m v) + (make-vec4 (dotproduct-vec4 (matrix4x4-1 m) v) + (dotproduct-vec4 (matrix4x4-2 m) v) + (dotproduct-vec4 (matrix4x4-3 m) v) + (dotproduct-vec4 (matrix4x4-4 m) v)))) + +;; multiply homogenous matrix with (vec3,1) and project onto plane w=1 +;; transform-vec3 : matrix4x4 vec3 -> vec3 +(define transform-vec3 + (lambda (m v) + (let ((v4 (make-vec4 (vec3-x v) (vec3-y v) (vec3-z v) 1))) + (div-vec3 (make-vec3 (dotproduct-vec4 (matrix4x4-1 m) v4) + (dotproduct-vec4 (matrix4x4-2 m) v4) + (dotproduct-vec4 (matrix4x4-3 m) v4)) + (dotproduct-vec4 (matrix4x4-4 m) v4))))) + + +;; return a*b +;; multiply-matrix : matrix4x4 matrix4x4 -> matrix4x4 +(define multiply-matrix + (lambda (a b) + (let ( (b^T (transpose-matrix4x4 b)) ) + (make-matrix4x4 + (make-vec4 (dotproduct-vec4 (matrix4x4-1 a) (matrix4x4-1 b^T)) + (dotproduct-vec4 (matrix4x4-1 a) (matrix4x4-2 b^T)) + (dotproduct-vec4 (matrix4x4-1 a) (matrix4x4-3 b^T)) + (dotproduct-vec4 (matrix4x4-1 a) (matrix4x4-4 b^T))) + (make-vec4 (dotproduct-vec4 (matrix4x4-2 a) (matrix4x4-1 b^T)) + (dotproduct-vec4 (matrix4x4-2 a) (matrix4x4-2 b^T)) + (dotproduct-vec4 (matrix4x4-2 a) (matrix4x4-3 b^T)) + (dotproduct-vec4 (matrix4x4-2 a) (matrix4x4-4 b^T))) + (make-vec4 (dotproduct-vec4 (matrix4x4-3 a) (matrix4x4-1 b^T)) + (dotproduct-vec4 (matrix4x4-3 a) (matrix4x4-2 b^T)) + (dotproduct-vec4 (matrix4x4-3 a) (matrix4x4-3 b^T)) + (dotproduct-vec4 (matrix4x4-3 a) (matrix4x4-4 b^T))) + (make-vec4 (dotproduct-vec4 (matrix4x4-4 a) (matrix4x4-1 b^T)) + (dotproduct-vec4 (matrix4x4-4 a) (matrix4x4-2 b^T)) + (dotproduct-vec4 (matrix4x4-4 a) (matrix4x4-3 b^T)) + (dotproduct-vec4 (matrix4x4-4 a) (matrix4x4-4 b^T))))))) + +;; create a matrix which translates (moves) by a 3d-vector +;; create-translation-matrix: vec3 -> matrix4x4 +(define create-translation-matrix + (lambda (translation) + (make-matrix4x4 + (make-vec4 1 0 0 (vec3-x translation)) + (make-vec4 0 1 0 (vec3-y translation)) + (make-vec4 0 0 1 (vec3-z translation)) + (make-vec4 0 0 0 1)))) + +;; create a matrix which rotates around the x-axis +;; create-rotation-x-matrix: Number -> matrix4x4 +(define create-rotation-x-matrix + (lambda (angle) + (make-matrix4x4 + (make-vec4 1 0 0 0) + (make-vec4 0 (cos angle) (sin angle) 0) + (make-vec4 0 (-(sin angle)) (cos angle) 0) + (make-vec4 0 0 0 1)))) + +;; create a matrix which rotates around the y-axis +;; create-rotation-y-matrix: Number -> matrix4x4 +(define create-rotation-y-matrix + (lambda (angle) + (make-matrix4x4 + (make-vec4 (cos angle) 0 (sin angle) 0) + (make-vec4 0 1 0 0) + (make-vec4 (-(sin angle)) 0 (cos angle) 0) + (make-vec4 0 0 0 1)))) + +;; create a matrix which rotates around the z-axis +;; create-rotation-z-matrix: Number -> matrix4x4 +(define create-rotation-z-matrix + (lambda (angle) + (make-matrix4x4 + (make-vec4 (cos angle) (sin angle) 0 0) + (make-vec4 (-(sin angle)) (cos angle) 0 0) + (make-vec4 0 0 1 0) + (make-vec4 0 0 0 1)))) + +(define PI 3.14159265) +(define PI/2 (/ PI 2)) +(define PI/4 (/ PI 4)) + +; output a vector +; print-vec4 : vec4 -> string +(define print-vec4 + (lambda (v) + (string-append (number->string (vec4-x v)) "\t" + (number->string (vec4-y v)) "\t" + (number->string (vec4-z v)) "\t" + (number->string (vec4-w v))))) + +; output a matrix +; print-matrix4x4 : matrix4x4 -> string +(define print-matrix4x4 + (lambda (m) + (let ((m^T (transpose-matrix4x4 m))) + (string-append (print-vec4 (matrix4x4-1 m^T)) "\n" + (print-vec4 (matrix4x4-2 m^T)) "\n" + (print-vec4 (matrix4x4-3 m^T)) "\n" + (print-vec4 (matrix4x4-4 m^T)) "\n")))) + +;; --------------------------------------------- +;; camera and projection +;; --------------------------------------------- + +; create a look-at modelview matrix +; M = (v1 v2 v3 v4) +; (0 0 0 1 ) +; v1 = (lookat - position) x upvector +; v2 = ((lookat - position) x upvector) x (lookat - position) +; v3 = (lookat - position) +; v4 = (0 0 0) +; create-lookat-matrix : vec3 vec3 vec3 -> matrix4x4 +(define create-lookat-matrix + (lambda (position lookat upvector) + (let* ((viewdirection (normalize-vec3 (sub-vec3 position lookat))) + (normed-upvector (normalize-vec3 upvector)) + (rightvector (crossproduct-vec3 viewdirection normed-upvector))) + (multiply-matrix + (create-matrix4x4 + (normalize-vec3 rightvector) + (normalize-vec3 (crossproduct-vec3 rightvector viewdirection)) + viewdirection + (make-vec3 0 0 0)) + (create-translation-matrix (mult-vec3 position -1)))))) + +; projection with a specified vertical viewing angle +; create-projection-matrix : number -> matrix4x4 +(define create-projection-matrix + (lambda (vertical-fov/2) + (let ((f (/ (cos vertical-fov/2) (sin vertical-fov/2)))) + (make-matrix4x4 + (make-vec4 f 0 0 0) + (make-vec4 0 f 0 0) + (make-vec4 0 0 0 0) + (make-vec4 0 0 1 0))))) + +; transforms camera-space into image-space +; create-viewport-matrix : number number -> number +(define create-viewport-matrix + (lambda (screenwidth screenheight) + (let ((screenwidth/2 (/ screenwidth 2)) + (screenheight/2 (/ screenheight 2))) + (make-matrix4x4 + (make-vec4 screenwidth/2 0 0 screenwidth/2) + (make-vec4 0 screenheight/2 0 screenheight/2) + (make-vec4 0 0 1/2 0) + (make-vec4 0 0 0 1))))) + +; create a complete camera matrix +; create-camera-matrix : +(define create-camera-matrix + (lambda (position lookat vertical-fov screenwidth screenheight) + (multiply-matrix + (multiply-matrix + (create-viewport-matrix screenwidth screenheight) + (create-projection-matrix (* (/ vertical-fov 360) PI))) + (create-lookat-matrix position lookat (make-vec3 0 1 0))))) + +;; ---------------------------------------------- +;; scene +;; ---------------------------------------------- + +; defines a colored line between two points (3D) +(define-record-procedures line3d + make-line3d line3d? + (line3d-a line3d-b line3d-color)) + +; creates a box centered at (0,0,0) with the given dimensions. +; create-box : number number number color -> list(line3d) +(define create-box + (lambda (width height depth color) + (let ((corner1 (make-vec3 (- width) (- height) (- depth))) + (corner2 (make-vec3 width (- height) (- depth))) + (corner3 (make-vec3 width height (- depth))) + (corner4 (make-vec3 (- width) height (- depth))) + (corner5 (make-vec3 (- width) (- height) depth)) + (corner6 (make-vec3 width (- height) depth)) + (corner7 (make-vec3 width height depth)) + (corner8 (make-vec3 (- width) height depth))) + (list + (make-line3d corner1 corner2 color) + (make-line3d corner2 corner3 color) + (make-line3d corner3 corner4 color) + (make-line3d corner4 corner1 color) + (make-line3d corner5 corner6 color) + (make-line3d corner6 corner7 color) + (make-line3d corner7 corner8 color) + (make-line3d corner8 corner5 color) + (make-line3d corner1 corner5 color) + (make-line3d corner1 corner5 color) + (make-line3d corner2 corner6 color) + (make-line3d corner3 corner7 color) + (make-line3d corner4 corner8 color))))) + +; apply transformation to every given line +; transform-primitive-list: list(line3d) matrix4x4 -> list(line3d) +(define transform-primitive-list + (lambda (l mat) + (cond + ((pair? l) (transform-primitive-list-helper l mat empty)) + ((empty? l) empty)))) + +; transform-primitive-list-helper : list(line3d) matrix4x4 list(line3d) -> list(line3d) +(define transform-primitive-list-helper + (lambda (l mat result) + (cond + ((pair? l) + (transform-primitive-list-helper (rest l) mat + (make-pair (make-line3d (transform-vec3 mat (line3d-a (first l))) + (transform-vec3 mat (line3d-b (first l))) + (line3d-color (first l))) result))) + ((empty? l) result)))) + +;; --------------------------------------------- +;; rendering +;; --------------------------------------------- + +; w-clip epsilon +(define clip-epsilon -0.1) + +;; clip line on plane w=clip-epsilon +;; clipline: vec4 vec4 color -> image +(define clipline + (lambda (screenWidth screenHeight inside outside color) + (let* ((delta-vec (sub-vec4 outside inside)) + (f (/ (- clip-epsilon (vec4-w inside)) (- (vec4-w outside) (vec4-w inside)))) + ; compute intersection with clipping plane + (clipped-point (add-vec4 inside (mult-vec4 delta-vec f))) + ; project points by normalising to w=1 + (inside-projected (div-vec4 inside (vec4-w inside))) + (clipped-point-projected (div-vec4 clipped-point (vec4-w clipped-point)))) + (line screenWidth screenHeight (vec4-x inside-projected) (vec4-y inside-projected) + (vec4-x clipped-point-projected) (vec4-y clipped-point-projected) color)))) + + +; render line with clipping +; render-clipped-line3d : N N vec4 vec4 matrix4x4 -> image +(define render-clipped-line3d + (lambda (screenWidth screenHeight l camera-matrix) + (let* ((point-a (line3d-a l)) + (point-b (line3d-b l)) + (point-a-transformed (multiply-matrix-vec4 camera-matrix + (make-vec4 (vec3-x point-a) (vec3-y point-a) (vec3-z point-a) 1))) + (point-b-transformed (multiply-matrix-vec4 camera-matrix + (make-vec4 (vec3-x point-b) (vec3-y point-b) (vec3-z point-b) 1))) + (projected-point1 (transform-vec3 camera-matrix (line3d-a l))) + (projected-point2 (transform-vec3 camera-matrix (line3d-b l)))) + (cond + ((and (< (vec4-w point-a-transformed) clip-epsilon) + (< (vec4-w point-b-transformed) clip-epsilon)) + (line screenWidth screenHeight (vec3-x projected-point1) (vec3-y projected-point1) + (vec3-x projected-point2) (vec3-y projected-point2) (line3d-color l))) + ((and (>= (vec4-w point-a-transformed) clip-epsilon) + (< (vec4-w point-b-transformed) clip-epsilon)) + (clipline screenWidth screenHeight point-b-transformed point-a-transformed (line3d-color l))) + ((and (>= (vec4-w point-b-transformed) clip-epsilon) + (< (vec4-w point-a-transformed) clip-epsilon)) + (clipline screenWidth screenHeight point-a-transformed point-b-transformed (line3d-color l))) + (else (line screenWidth screenHeight -1 0 0 0 (line3d-color l))))))) + +; render line without clipping (not used anymore) +; render-line3d : N N line3d matrix4x4 -> image +(define render-line3d + (lambda (screenWidth screenHeight l camera-matrix) + (let ((projected-point1 (transform-vec3 camera-matrix (line3d-a l))) + (projected-point2 (transform-vec3 camera-matrix (line3d-b l)))) + (line screenWidth screenHeight (vec3-x projected-point1) (vec3-y projected-point1) + (vec3-x projected-point2) (vec3-y projected-point2) (line3d-color l))))) + +; render scene into an image +; render-scene: N N list(line3d) matrix4x4 -> image +(define render-scene + (lambda (screenWidth screenHeight scene camera-matrix) + (cond + ((empty? scene)(line screenWidth screenHeight 0 0 0 0 "white")) + ((pair? scene) + (render-scene-helper screenWidth screenHeight (rest scene) camera-matrix + (render-clipped-line3d screenWidth screenHeight (first scene) camera-matrix)))))) + +; render-scene-helper: list(line3d) matrix4x4 image -> image +(define render-scene-helper + (lambda (screenWidth screenHeight scene camera-matrix screen) + (cond + ((empty? scene) screen) + ((pair? scene) (render-scene-helper screenWidth screenHeight (rest scene) camera-matrix + (overlay screen + (render-clipped-line3d screenWidth screenHeight (first scene) camera-matrix) 0 0)))))) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/teachpack/turtle.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/teachpack/turtle.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/teachpack/turtle.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/teachpack/turtle.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,219 @@ +#lang scheme + +(require mzlib/math + (only-in deinprogramm/DMdA/teachpack/image rectangle line overlay image-color? image image-color) + (only-in lang/private/imageeq image?) + deinprogramm/signature/signature-syntax) + +(provide set-color + turn + draw + move + run + sequence + turtle + image + image-color) + + ; used to convert angles + (define pi/180 (/ pi 180)) + + ; convert angle value + ; (: grad->rad (number -> number)) + (define grad->rad + (lambda (grad) + (* pi/180 grad))) + + (define turtle (signature + (predicate (lambda (x) + (and (vector? x) + (= (vector-length x) 8) + (number? (vector-ref x 0)) + (number? (vector-ref x 1)) + (number? (vector-ref x 2)) + (number? (vector-ref x 3)) + (number? (vector-ref x 4)) + (image? (vector-ref x 5)) + (image-color? (vector-ref x 6))))))) + + ; This function is only for internal use. + ; (new-turtle-priv h w x y angle img color state) + ; creates a new turtle with hight h, width w. + ; The cursor is at position (x,y) and the view direction + ; is defined by an angle value relative to the vector (1,0) . + ; The two next componets represents the image and the + ; color of the pen. The last component represents an abritary + ; value, that allows to transport state with the turtle. + (: new-turtle-priv (number number number number number image image-color %A -> turtle)) + (define new-turtle-priv + (lambda (h w x y angle img color state) + (vector h w x y angle img color state))) + + + ; (new-turtle h w color) + ; creates a new turtle with the pen color color and sets the + ; width of the image to w and the hight to h. + ; The background of the image is gray and the position of the + ; cursor is (0,0) and the view direction is (1,0). + (: new-turtle (number number image-color -> turtle)) + (define new-turtle + (lambda (h w color) + (let ((x (floor (/ w 2))) + (y (floor (/ h 2)))) + (new-turtle-priv h w x y 0 (rectangle w h "solid" "gray") color #f)))) + + ; (new-turtle-complex h w color bgcolor x y angle) + ; creates a new turtle with the pen color color and sets the + ; width of the image to w and the hight to h. + ; The background of the image is bgcolor and the position of the + ; cursor is (x,y) and the view direction is (1,0) * e^(- i angle). + (: new-turtle (number number image-color image-color number number number -> turtle)) + (define new-turtle-complex + (lambda (h w color bgcolor x y angle) + (new-turtle-priv h w x y angle (rectangle w h "solid" bgcolor) color #f))) + + + ; For internal use only + (: get-h (turtle -> number)) + (define get-h (lambda (t) (vector-ref t 0))) + (: get-w (turtle -> number)) + (define get-w (lambda (t) (vector-ref t 1))) + (: get-x (turtle -> number)) + (define get-x (lambda (t) (vector-ref t 2))) + (: get-y (turtle -> number)) + (define get-y (lambda (t) (vector-ref t 3))) + (: get-angle (turtle -> number)) + (define get-angle (lambda (t) (vector-ref t 4))) + (: get-iamge (turtle -> image)) + (define get-image (lambda (t) (vector-ref t 5))) + (: get-color (turtle -> image-color)) + (define get-color (lambda (t) (vector-ref t 6))) + (: get-state (turtle -> %A)) + (define get-state (lambda (t) (vector-ref t 7))) + + ; (set-color color) + ; returns a function of type turtle -> turtle. + ; Use the result to change the color of the pen. + (: set-color (image-color -> (turtle -> turtle))) + (define set-color + (lambda (color) + (lambda (t) + (let* ((h (get-h t)) + (w (get-w t)) + (x (get-x t)) + (y (get-y t)) + (angle (get-angle t)) + (image (get-image t))) + (new-turtle-priv h w x y angle image color #f))))) + + ; (turn angle) + ; returns a function of type turtle -> turtle. + ; Use the result to turn the view of the turtle (counter-clockwise). + (: turn (number -> (turtle -> turtle))) + (define turn + (lambda (grad) + (lambda (t) + (let* ((h (get-h t)) + (w (get-w t)) + (x (get-x t)) + (y (get-y t)) + (angle (get-angle t)) + (image (get-image t)) + (color (get-color t)) + (state (get-state t))) + (new-turtle-priv h w x y (- angle grad) image color state))))) + + ; For internal use only + ; (move-cursor turtle length) + ; returns a new turtle where the cursor + ; is moved length steps along the view vector. + (: move-cursor (turtle number -> turtle)) + (define move-cursor + (lambda (t length) + (let* ((h (get-h t)) + (w (get-w t)) + (x (get-x t)) + (y (get-y t)) + (angle (get-angle t)) + (image (get-image t)) + (color (get-color t)) + (state (get-state t)) + (newx (+ x (* length (cos (grad->rad angle))))) + (newy (+ y (* length (sin (grad->rad angle)))))) + (new-turtle-priv h w newx newy angle image color state)))) + + ; (draw length) + ; returns a function of type turtle -> turtle. + ; The result can be used to move the turtle and draw a line. + (: draw (number -> (turtle -> turtle))) + (define draw + (lambda (length) + (lambda (t) + (let* ((h (get-h t)) + (w (get-w t)) + (x (get-x t)) + (y (get-y t)) + (angle (get-angle t)) + (image (get-image t)) + (color (get-color t)) + (state (get-state t)) + ; Compute new coordinats + (newx (+ x (* length (cos (grad->rad angle))))) + (newy (+ y (* length (sin (grad->rad angle)))))) + (new-turtle-priv + h w + newx newy angle + ; Compute new image + (overlay image + (line w h x y newx newy color) 0 0) + color state))))) + + ; (move length) + ; returns a function of type turtle -> turtle. + ; The result can be used to move the turtle without drawing a line. + (: move (number -> (turtle -> turtle))) + (define move + (lambda (length) + (lambda (t) + (move-cursor t length)))) + + ; runs a turtle function + (: run ((turtle -> turtle) number number image-color -> image)) + (define run + (lambda (t->t h w color) + (get-image (t->t (new-turtle h w color))))) + +; ; runs a turtle function +; ; (: run* ((turtle -> turtle) -> turtle -> image)) +; (define run* +; (lambda (t->t h w color bgcolor x y angle) +; (get-image (t->t (new-turtle h w color bgcolor x y angle))))) + + ; This function is only for internal use. + (define comp_priv_2 + (lambda (f1 f2) + (lambda (t) + (f2 (f1 t))))) + + ; This function is only for internal use. + (define comp_priv + (lambda (l) + (cond + ((null? l) (error "sequence erwartet mind. ein Argument")) + ((list? l) + (let ((head (car l)) + (tail (cdr l))) + (if (null? tail) + head + (comp_priv_2 head (comp_priv tail)))))))) + + ; This function allows to do a list of + ; turtle -> turtle + ; functions into one new function, that do + ; one action of the turtle, then later the rest. + ; Define the type alias tip = turtle -> turtle. + (define tip (signature (turtle -> turtle))) + (: do (tip ... -> tip)) + (define sequence (lambda l (comp_priv l))) + + diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/teachpack/world.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/teachpack/world.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/teachpack/world.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/teachpack/world.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,270 @@ +#lang scheme/base + +;; Mon Mar 27 10:29:28 EST 2006: integrated Felix's mouse events +;; Wed Jan 25 13:38:42 EST 2006: on-redraw: proc is now called on installation +;; Tue Jan 3 11:17:50 EST 2006: changed add-line behavior in world.rkt +;; Sat Dec 10 19:39:03 EST 2005: fixed name, changed interface to on-key-event +;; Fri Dec 9 21:39:03 EST 2005: remoevd (update ... produce ...); added on-redraw +;; Thu Dec 1 17:03:03 EST 2005: fixed place-image; all coordinates okay now + + (require + (except-in mred make-color) + mzlib/class + htdp/error + "image.rkt" + (prefix-in beg: lang/htdp-beginner) + lang/prim + deinprogramm/signature/signature-syntax) + + ;; --- provide --------------------------------------------------------------- + (provide (all-from-out "image.rkt")) + + (provide ;; forall(World): + big-bang ;; Number Number Number World -> true + end-of-time ;; String u Symbol -> World + ) + + (provide-higher-order-primitive + on-tick-event (tock) ;; (World -> World) -> true + ) + + (provide-higher-order-primitive + on-redraw (world-image) ;; (World -> Image) -> true + ) + + ;; KeyEvent is one of: + ;; -- Char + ;; -- Symbol + + (provide-higher-order-primitive ;; (World KeyEvent -> World) -> true + on-key-event + (draw) + ) + + ;; A MouseEventKind is one of: + ;; "enter" -- mouse pointer entered the window + ;; "leave" -- mouse pointer left the window + ;; "left-down" -- left mouse button pressed + ;; "left-up" -- left mouse button released + ;; "middle-down" -- middle mouse button pressed + ;; "middle-up" -- middle mouse button released + ;; "right-down" -- right mouse button pressed (Mac OS: click with control key pressed) + ;; "right-up" -- right mouse button released (Mac OS: release with control key pressed) + ;; "motion" -- mouse moved, with or without button(s) pressed + + + (provide-higher-order-primitive ;; (World Number Number MouseEventKind -> World) -> true + on-mouse-event + (clack) + ) + + (provide mouse-event-kind) + + (define mouse-event-kind + (signature + (one-of "enter" "leave" "motion" "left-down" "left-up" "middle-down" "middle-up" "right-down" "right-up"))) + + ;; --------------------------------------------------------------------------- + + ;; Symbol Any String -> Void + (define (check-pos tag c rank) + (check-arg tag (and (number? c) (integer? c) (>= c 0)) "positive integer" rank c)) + + ;; --------------------------------------------------------------------------- + + ;; The One and Only Visible World + (define the-frame #f) + (define txt (new text%)) + + ;; World (type parameter) + (define the-world0 (cons 1 1)) + [define the-world the-world0] + + (define (check-world tag) + (when (eq? the-world0 the-world) (error tag SEQUENCE-ERROR))) + + ;; Number > 0 + [define the-delta 1000] + + ;; Amount of space around the image in the world window: + (define INSET 5) + + ;; Number Number Number World -> true + ;; create the visible world (canvas) + (define (big-bang w h delta world) + (check-pos 'big-bang w "first") + (check-pos 'big-bang h "second") + (check-arg 'big-bang + (and (number? delta) (<= 0 delta 1000)) + "number [of seconds] between 0 and 1000" + "first" + delta) + (when the-frame (error 'big-bang "big-bang already called once")) + (set! the-delta delta) + (set! the-world world) + (set! the-frame + (new (class frame% + (super-new) + (define/augment (on-close) + ;; shut down the timer when the window is destroyed + (send the-time stop) + (inner (void) on-close))) + (label "DrRacket") + (stretchable-width #f) + (stretchable-height #f) + (style '(no-resize-border metal)))) + (let ([c (new (class editor-canvas% + (super-new) + (define/override (on-char e) + (on-char-proc (send e get-key-code))) + (define/override (on-event e) + (on-mouse-proc e))) + (parent the-frame) + (editor txt) + (style '(no-hscroll no-vscroll)) + (horizontal-inset INSET) + (vertical-inset INSET))]) + (send c min-client-width (+ w INSET INSET)) + (send c min-client-height (+ h INSET INSET)) + (send c focus)) + (send txt set-cursor (make-object cursor% 'arrow)) + (send txt hide-caret #t) + (send the-frame show #t) + #t) + + ;; --- time events + [define the-time (new timer% [notify-callback (lambda () (timer-callback))])] + + ;; (World -> World) + [define timer-callback void] + + [define (on-tick-event f) + (check-proc 'on-tick-event f 1 "on-tick-event" "one argument") + (check-world 'on-tick-event) + (if (eq? timer-callback void) + (set! timer-callback + (lambda () + (with-handlers ([exn:break? break-handler] + [exn? exn-handler]) + (set! the-world (f the-world)) + (on-redraw-proc)))) + (error 'on-tick "the timing action has been set already")) + (send the-time start + (let* ([w (ceiling (* 1000 the-delta))]) + (if (exact? w) w (inexact->exact w)))) + #t] + + ;; --- key and mouse events + + ;; KeyEvent -> Void + [define on-char-proc void] + + [define (on-key-event f) + (check-proc 'on-key-event f 2 "on-key-event" "two arguments") + (check-world 'on-key-event) + (let ([esp (current-eventspace)]) + (if (eq? on-char-proc void) + (begin + (set! on-char-proc + (lambda (e) + (cond + ((event->string e) + => (lambda (s) + (parameterize ([current-eventspace esp]) + (queue-callback + (lambda () + (with-handlers ([exn:break? break-handler] + [exn? exn-handler]) + (set! the-world (f the-world s)) + (on-redraw-proc)))))))) + #t)) + #t) + (error 'on-event "the event action has been set already")))] + + (define (event->string e) + (if (char? e) + (string e) + (case e + ((left) "left") + ((right) "right") + ((up) "up") + ((down) "down") + ((wheel-up) "wheel-up") + ((wheel-down) "wheel-down") + (else #f)))) + + [define (end-of-time s) + (printf "end of time: ~a\n" s) + (stop-it) + the-world] + + ;; MouseEvent -> Void + [define on-mouse-proc void] + + [define (on-mouse-event f) + (check-proc 'on-mouse-event f 4 "on-mouse-event" "four arguments") + (check-world 'on-mouse-event) + (let ([esp (current-eventspace)]) + (if (eq? on-mouse-proc void) + (begin + (set! on-mouse-proc + (lambda (e) + (parameterize ([current-eventspace esp]) + (queue-callback + (lambda () + (with-handlers ([exn:break? break-handler] + [exn? exn-handler]) + (set! the-world (f the-world + (send e get-x) + (send e get-y) + (symbol->string (send e get-event-type)))) + (on-redraw-proc)))) + #t))) + #t) + (error 'on-mouse-event "the mouse event action has been set already")))] + + ;; --- library + [define (exn-handler e) + (send the-time stop) + (set! on-char-proc void) + (set! timer-callback void) + (raise e)] + + [define (break-handler . _) + (printf "animation stopped") + (stop-it) + the-world] + + ;; -> Void + (define (stop-it) + (send the-time stop) + (set! on-char-proc void) + (set! timer-callback void)) + + (define on-redraw-proc void) + + (define (on-redraw f) + (check-proc 'on-redraw f 1 "on-redraw" "one argument") + (check-world 'on-redraw) + (if (eq? on-redraw-proc void) + (begin + (set! on-redraw-proc + (lambda () + (with-handlers ([exn:break? break-handler] + [exn? exn-handler]) + (define img (f the-world)) + (check-result 'on-redraw (lambda (x) (beg:image? x)) "image" img) + (update-frame img) + #t))) + (on-redraw-proc)) + (error 'on-redraw "the redraw function has already been specified"))) + + (define (update-frame pict) + (send txt begin-edit-sequence) + (send txt lock #f) + (send txt delete 0 (send txt last-position) #f) + (send txt insert (send pict copy) 0 0 #f) + (send txt lock #t) + (send txt end-edit-sequence)) + + (define SEQUENCE-ERROR "evaluate (big-bang Number Number Number World) first") diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/tests/image.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/tests/image.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/tests/image.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/tests/image.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,1038 @@ +#lang scheme/base + +(provide all-image-tests) + +(require rackunit + deinprogramm/DMdA/teachpack/image + (only-in lang/private/imageeq image=?) + (except-in mred make-color make-pen) + mzlib/class + mrlib/cache-image-snip + lang/posn + htdp/error) + + +(define-values (image-snip1 image-snip2) + (let () + (define size 2) + + (define (do-draw c-bm m-bm) + (let ([bdc (make-object bitmap-dc% c-bm)]) + (send bdc clear) + (send bdc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) + (send bdc set-brush (send the-brush-list find-or-create-brush "red" 'solid)) + (send bdc draw-rectangle 0 0 size size) + (send bdc set-bitmap m-bm) + (send bdc clear) + (send bdc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) + (send bdc set-brush (send the-brush-list find-or-create-brush "black" 'solid)) + (send bdc draw-rectangle 0 0 (/ size 2) size) + (send bdc set-bitmap #f))) + + (define image-snip1 + (let* ([c-bm (make-object bitmap% size size)] + [m-bm (make-object bitmap% size size #t)]) + (do-draw c-bm m-bm) + (make-object image-snip% c-bm m-bm))) + + (define image-snip2 + (let* ([c-bm (make-object bitmap% size size)] + [m-bm (make-object bitmap% size size)]) + (do-draw c-bm m-bm) + (send c-bm set-loaded-mask m-bm) + (make-object image-snip% c-bm))) + + (values image-snip1 image-snip2))) + +(define image-snip3 (make-object image-snip%)) + +;; check-on-bitmap : symbol snip -> void +;; checks on various aspects of the bitmap snips to make +;; sure that they draw properly +(define (check-on-bitmap snp) + (let-values ([(width height) (send snp get-size)]) + (let ([bdc (make-object bitmap-dc%)] + [max-difference + (lambda (s1 s2) + (cond + [(and (zero? (bytes-length s1)) + (zero? (bytes-length s2))) + 0] + [else + (apply max + (map (lambda (x y) (abs (- x y))) + (bytes->list s1) + (bytes->list s1)))]))]) + + ;; test that no drawing is outside the snip's drawing claimed drawing area + (let* ([extra-space 100] + [bm-width (+ width extra-space)] + [bm-height (+ height extra-space)] + [bm-clip (make-object bitmap% bm-width bm-height)] + [bm-noclip (make-object bitmap% bm-width bm-height)] + [s-clip (make-bytes (* bm-width bm-height 4))] + [s-noclip (make-bytes (* bm-width bm-height 4))] + [s-trunc (make-bytes (* bm-width bm-height 4))]) + (send bdc set-bitmap bm-clip) + (send bdc clear) + (send bdc set-clipping-rect (/ extra-space 2) (/ extra-space 2) width height) + (send snp draw bdc (/ extra-space 2) (/ extra-space 2) 0 0 (+ width extra-space) (+ height extra-space) 0 0 #f) + (send bdc set-clipping-region #f) + (send bdc get-argb-pixels 0 0 (+ width extra-space) (+ height extra-space) s-clip) + + (send bdc set-bitmap bm-noclip) + (send bdc clear) + (send snp draw bdc (/ extra-space 2) (/ extra-space 2) 0 0 (+ width extra-space) (+ height extra-space) 0 0 #f) + (send bdc get-argb-pixels 0 0 (+ width extra-space) (+ height extra-space) s-noclip) + (send bdc set-bitmap #f) + + (check-equal? s-clip s-noclip) + + (send bdc set-bitmap bm-noclip) + (send bdc set-pen "black" 1 'transparent) + (send bdc set-brush "white" 'solid) + (send bdc draw-rectangle 0 0 (/ extra-space 2) bm-height) + (send bdc draw-rectangle (- bm-width (/ extra-space 2)) 0 (/ extra-space 2) bm-height) + (send bdc draw-rectangle 0 0 bm-width (/ extra-space 2)) + (send bdc draw-rectangle 0 (- bm-height (/ extra-space 2)) bm-width (/ extra-space 2)) + (send bdc get-argb-pixels 0 0 (+ width extra-space) (+ height extra-space) s-trunc) + + (check-equal? s-noclip s-trunc)) + + (let ([bm-normal (make-object bitmap% (max 1 width) (max 1 height))] + [bm-bitmap (make-object bitmap% (max 1 width) (max 1 height))] + [s-normal (make-bytes (* (max 1 width) (max 1 height) 4))] + [s-bitmap (make-bytes (* (max 1 width) (max 1 height) 4))]) + + (send bdc set-bitmap bm-normal) + (send bdc clear) + (send snp draw bdc 0 0 0 0 width height 0 0 #f) + (send bdc get-argb-pixels 0 0 width height s-normal) + (send bdc set-bitmap bm-bitmap) + (send bdc clear) + + ;; force the snip to switch over to bitmap mode + (send snp get-argb) + + (send snp draw bdc 0 0 0 0 width height 0 0 #f) + (send bdc get-argb-pixels 0 0 width height s-bitmap) + (send bdc set-bitmap #f) + (check-true (<= (max-difference s-normal s-bitmap) 2)))))) + +(define red (make-color 255 0 0)) +(define blue (make-color 0 0 255)) +(define black (make-color 0 0 0)) +(define white (make-color 255 255 255)) + +(define awhite (make-alpha-color 0 255 255 255)) +(define ablack (make-alpha-color 0 0 0 0)) +(define ared (make-alpha-color 0 255 0 0)) +(define aclr (make-alpha-color 255 0 0 0)) + +(define-simple-check (check-image=? i1 i2) + (image=? i1 i2)) + +(define-simple-check (check-not-image=? i1 i2) + (not (image=? i1 i2))) + +(define-simple-check (check-terminates val1) + #t) + +(define (add-line i x1 y1 x2 y2 color) + (overlay i + (line (image-width i) + (image-height i) + x1 y1 x2 y2 color) + "left" "top")) + +(define (not-image-inside? i1 i2) + (not (image-inside? i1 i2))) + +;; tests that the expression +;; a) raises a teachpack exception record, +;; b) has the right argument position, and +;; c) has the right name. +(define (tp-exn-pred name position) + (lambda (exn) + (and (exn:fail:contract? exn) + (let* ([msg (exn-message exn)] + [beg (format "~a:" name)] + [len (string-length beg)]) + (and (regexp-match position msg) + ((string-length msg) . > . len) + (string=? (substring msg 0 len) beg)))))) + +(define-syntax err/rt-name-test + (syntax-rules () + [(_ (name . args) position) + (check-exn (tp-exn-pred 'name position) + (lambda () + (name . args)))])) + +(define all-image-tests + (test-suite + "Tests for images" + + (test-case + "image?" + (check-pred image? (rectangle 10 10 'solid 'blue)) + (check-pred image? (rectangle 10 10 "solid" 'blue)) + (check-pred image? (rectangle 10 10 'outline 'blue)) + (check-pred image? (rectangle 10 10 "outline" 'blue)) + (check-false (image? 5))) + + (test-case + "color-list" + (check-equal? (list red) + (image->color-list (rectangle 1 1 'solid 'red))) + (check-equal? (list blue blue blue blue) + (image->color-list (rectangle 2 2 'solid 'blue)))) + + (test-case + "colors-set-up-properly" + (check-equal? (list (list red) (list blue) (list black) (list white)) + (list (image->color-list (rectangle 1 1 'solid 'red)) + (image->color-list (rectangle 1 1 'solid 'blue)) + (image->color-list (rectangle 1 1 'solid 'black)) + (image->color-list (rectangle 1 1 'solid 'white))))) + + (test-case + "color-list2" + (check-equal? (list blue blue blue + blue blue blue + blue blue blue) + (image->color-list (rectangle 3 3 'solid 'blue))) + (check-equal? (list blue blue blue + blue blue blue + blue blue blue) + (image->color-list (rectangle 3 3 "solid" 'blue))) + ;; Robby says: + ;; I think that this test just isn't one that the primitives guarantee to hold. + #;(check-equal? (list blue blue blue + blue white blue + blue blue blue) + (image->color-list (rectangle 3 3 'outline 'blue)))) + + + ;; Ditto. + #;(test-case + "color-list3" + (check-equal? (list blue blue blue + blue white blue + blue blue blue) + (image->color-list (rectangle 3 3 "outline" 'blue)))) + + (test-case + "color-list4" + (check-image=? (color-list->image (list blue blue blue blue) 2 2) + (rectangle 2 2 'solid 'blue))) + (test-case + "color-list5" + (check-not-image=? (color-list->image (list blue blue blue blue) 2 2) + (rectangle 1 4 'solid 'blue))) + + (test-case + "color-list6" + (check-image=? (color-list->image (list blue blue blue blue) 1 4) + (rectangle 1 4 'solid 'blue))) + (test-case + "color-list7" + (check-image=? (color-list->image (list 'blue 'blue 'blue 'blue) 2 2) + (rectangle 2 2 'solid 'blue))) + + (test-case + "color-list8" + (check-equal? 10 + (image-width (color-list->image '() 10 0)))) + + (test-case + "color-list9" + (check-equal? 0 + (image-height (color-list->image '() 10 0)))) + + (test-case + "color-list10" + (check-equal? 0 + (image-width (color-list->image '() 0 10)))) + + (test-case + "color-list11" + (check-equal? 10 + (image-height (color-list->image '() 0 10)))) + + (test-case + "alpha-color-list1" + (check-equal? (make-alpha-color 0 255 0 0) + (car (image->alpha-color-list (rectangle 1 1 'solid 'red))))) + + (test-case + "alpha-color-list2" + (check-equal? (make-alpha-color 0 255 0 0) + (car (image->alpha-color-list (rectangle 1 1 "solid" 'red))))) + + (test-case + "alpha-color-list3" + (for-each + (lambda (x) + (check-equal? x (make-alpha-color 0 255 0 0))) + (image->alpha-color-list (rectangle 1 1 "solid" 'red)))) + + (test-case + "alpha-color-list4" + (for-each + (lambda (x) + (check-equal? x (make-alpha-color 0 255 0 0))) + (image->alpha-color-list (rectangle 1 1 'solid 'red)))) + + (test-case + "alpha-color-list5" + (check-equal? (make-alpha-color 0 0 255 0) + (car (image->alpha-color-list (rectangle 1 1 'solid 'green))))) + + (test-case + "alpha-color-list6" + (check-equal? (make-alpha-color 0 0 0 255) + (car (image->alpha-color-list (rectangle 1 1 'solid 'blue))))) + + (test-case + "alpha-color-list7" + (check-equal? (image-width + (alpha-color-list->image + (list ared aclr ared + aclr aclr aclr) + 3 + 2)) + 3)) + (test-case + "alpha-color-list8" + (check-equal? (image-height + (alpha-color-list->image + (list ared aclr ared + aclr aclr aclr) + 3 + 2)) + 2)) + + (test-case + "alpha-color-list9" + (check-equal? (image->color-list + (alpha-color-list->image + (list ared aclr ared + aclr aclr aclr) + 3 2)) + (list red white red + white white white))) + (test-case + "alpha-color-list10" + (check-equal? (image->color-list + (overlay + (rectangle 3 3 'solid 'blue) + (alpha-color-list->image + (list ared aclr ared + aclr aclr aclr + ared aclr ared) + 3 3) + "left" "top")) + (list red blue red + blue blue blue + red blue red))) + + (test-case + "alpha-color-list11" + (check-equal? 10 (image-width (alpha-color-list->image '() 10 0)))) + + (test-case + "alpha-color-list12" + (check-equal? 0 (image-height (alpha-color-list->image '() 10 0)))) + + (test-case + "alpha-color-list13" + (check-equal? 0 (image-width (alpha-color-list->image '() 0 10)))) + + (test-case + "alpha-color-list14" + (check-equal? 10 (image-height (alpha-color-list->image '() 0 10)))) + + (test-case + "image=?1" + (check-image=? (alpha-color-list->image (list (make-alpha-color 200 100 150 175)) 1 1) + (alpha-color-list->image (list (make-alpha-color 200 100 150 175)) 1 1))) + + (test-case + "image=?2" + (check-image=? (alpha-color-list->image (list (make-alpha-color 255 100 100 100)) 1 1) + (alpha-color-list->image (list (make-alpha-color 255 200 200 200)) 1 1))) + + (test-case + "image=?3" + (check-not-image=? (alpha-color-list->image (list (make-alpha-color 200 100 100 100)) 1 1) + (alpha-color-list->image (list (make-alpha-color 200 200 200 200)) 1 1))) + + (test-case + "image=?4" + (check-not-image=? (alpha-color-list->image (list (make-alpha-color 200 100 150 175) + (make-alpha-color 200 100 150 175)) + 1 + 2) + (alpha-color-list->image (list (make-alpha-color 200 100 150 175) + (make-alpha-color 200 100 150 175)) + 2 + 1))) + + ;; This one is broken because of a fundamental problem with the + ;; image primitives. + #;(test-case + "image=?5" + (check-not-image=? (rectangle 4 4 'outline 'black) + (overlay + (rectangle 4 4 'outline 'black) + (circle 1 'solid 'red) + 0 0))) + + (test-case + "overlay" + (check-image=? (color-list->image (list blue red blue red) 2 2) + (overlay (rectangle 2 2 'solid 'red) + (rectangle 1 2 'solid 'blue) + "left" "top"))) + + (test-case + "overlay/multiple" + (check-image=? (overlay (rectangle 6 6 'solid 'red) + (overlay (rectangle 4 4 'solid 'white) + (rectangle 2 2 'solid 'blue) + "center" "center") + "center" "center") + (overlay (overlay (rectangle 6 6 'solid 'red) + (rectangle 4 4 'solid 'white) + "center" "center") + (rectangle 2 2 'solid 'blue) + "center" "center"))) + + (test-case + "overlay/empty-spaces-are-unmasked" + (check-image=? (color-list->image (list red red red blue) 2 2) + (overlay + (rectangle 2 2 'solid 'blue) + (overlay (rectangle 1 2 'solid 'red) + (rectangle 2 1 'solid 'red) + "left" "top") + "left" "top"))) + + (test-case + "overlay/xy1" + (check-image=? (color-list->image (list red blue red blue) 2 2) + (overlay (rectangle 2 2 'solid 'red) + (rectangle 1 2 'solid 'blue) + 1 0))) + + (test-case + "overlay/xy2" + (check-image=? (color-list->image (list red red red blue) 2 2) + (overlay (rectangle 2 2 'solid 'red) + (rectangle 1 1 'solid 'blue) + 1 1))) + + (test-case + "overlay/xy3" + (check-image=? (color-list->image (list red red blue blue) 2 2) + (overlay (rectangle 2 1 'solid 'red) + (rectangle 2 1 'solid 'blue) + 0 1))) + + (test-case + "overlay/xy/white" + (check-image=? (alpha-color-list->image (list ablack ablack ablack + ablack awhite ablack + ablack ablack ablack) + 3 3) + (overlay (rectangle 3 3 'solid 'black) + (rectangle 1 1 'solid 'white) + 1 1))) + + (test-case + "color-list->image/white-in-mask" + (check-image=? (color-list->image (list black red black + red red red + black red black) + 3 3) + (overlay (rectangle 3 3 'solid 'red) + (color-list->image (list black white black + white white white + black white black) + 3 3) + "left" "top"))) + + + (test-case + "overlay" + (check-image=? (color-list->image (list red blue red red blue red) 3 2) + (overlay (rectangle 3 2 'solid 'red) + (rectangle 1 2 'solid 'blue) + 1 0))) + + (test-case + "image=?-zero1" + (check-image=? (rectangle 0 10 'solid 'red) + (rectangle 0 10 'solid 'red))) + (test-case + "image=?-zero2" + (check-image=? (rectangle 0 10 'solid 'red) + (rectangle 0 10 'solid 'blue))) + (test-case + "image=?-zero3" + (check-not-image=? (rectangle 0 5 'solid 'red) + (rectangle 0 4'solid 'blue))) + + (test-case + "image-inside?1" + (check image-inside? + (overlay (rectangle 3 2 'solid 'red) + (rectangle 1 2 'solid 'blue) + 1 0) + (rectangle 1 2 'solid 'blue))) + + (test-case + "image-inside?2" + (check not-image-inside? + (overlay (rectangle 3 2 'solid 'red) + (rectangle 1 2 'solid 'blue) + 1 0) + (rectangle 1 2 'solid 'black))) + + (test-case + "image-inside?3" + (check image-inside? + (overlay (rectangle 3 2 'solid 'red) + (rectangle 1 2 'solid 'blue) + 1 0) + (rectangle 1 2 'solid 'red))) + + (test-case + "image-inside?4" + (check not-image-inside? + (overlay (rectangle 3 2 'solid 'red) + (rectangle 1 2 'solid 'blue) + 1 0) + (rectangle 2 1 'solid 'red))) + + (test-case + "image-inside?5" + (check image-inside? + (alpha-color-list->image (list (make-alpha-color 0 255 0 0)) 1 1) + (alpha-color-list->image (list (make-alpha-color 255 0 0 0)) 1 1))) + + (test-case + "image-inside?6" + (check not-image-inside? + (overlay (rectangle 3 2 'solid 'red) + (rectangle 1 2 'solid 'blue) + 1 0) + (color-list->image (list blue white white) + 3 1))) + + (test-case + "image-inside?7" + (check image-inside? + (overlay (rectangle 16 16 'solid 'red) + (ellipse 6 6 'outline 'blue) + 2 5) + (ellipse 6 6 'outline 'blue))) + + (test-case + "image-inside?8" + (check image-inside? + (overlay (rectangle (image-width (text "x" 12 'red)) + (image-height (text "x" 12 'red)) + 'solid + 'white) + (text "x" 12 'red) + "center" "center") + (text "x" 12 'red))) + + (test-case + "image-inside?9" + (check image-inside? + (text "y x y" 12 'red) + (text "x" 12 'red))) + + (test-case + "find-image1" + (check-equal? (make-posn 2 5) + (find-image (overlay (rectangle 16 16 'solid 'red) + (ellipse 6 6 'outline 'blue) + 2 5) + (ellipse 6 6 'outline 'blue)))) + + (test-case + "find-image2" + (check-equal? (make-posn 0 0) + (find-image (rectangle 16 16 'solid 'blue) + (ellipse 6 6 'outline 'blue)))) + + (test-case + "find-image3" + (check-equal? (make-posn 1 1) + (find-image (overlay (rectangle 10 10 'solid 'blue) + (ellipse 5 5 'solid 'red) + 1 1) + (ellipse 5 5 'solid 'red)))) + + (test-case + "image-width" + (check-equal? 5 (image-width (rectangle 5 7 'solid 'red)))) + + (test-case + "image-height" + (check-equal? 7 (image-height (rectangle 5 7 'solid 'red)))) + + (test-case + "color-red" + (check-equal? 1 (color-red (make-color 1 2 3)))) + + (test-case + "color-green" + (check-equal? 2 (color-green (make-color 1 2 3)))) + + (test-case + "color-blue" + (check-equal? 3 (color-blue (make-color 1 2 3)))) + + (test-case + "color?1" + (check-true (color? (make-color 1 2 3)))) + + (test-case + "color?2" + (check-false (color? 10))) + + (test-case + "image-color?1" + (check-pred image-color? (make-color 1 2 3))) + + (test-case + "image-color?2" + (check-pred image-color? "blue")) + + (test-case + "image-color?3" + (check-pred image-color? 'blue)) + + (test-case + "image-color?4" + (check-false (image-color? 10))) + + (test-case + "image-color?5" + (check-false (image-color? "not-a-color"))) + + (test-case + "image-color?6" + (check-false (image-color? 'not-a-color))) + + (test-case + "line" + (check image=? + (line 5 1 0 0 4 0 'red) + (color-list->image (list red red red red red) 5 1)) + (check image=? + (line 1 5 0 0 0 4 'red) + (color-list->image (list red red red red red) 1 5)) + + (check image=? + (line 1 5 0 4 0 0 'red) + (color-list->image (list red red red red red) 1 5)) + + (check image=? + (line 5 1 4 0 0 0 'red) + (color-list->image (list red red red red red) 5 1))) + + +; note: next two tests may be platform-specific... I'm not sure. + ;; I developed them under macos x. -robby + ;; And sure enough, this one doesn't work anymore. -Mike + #;(test-case + "triangle1" + (check image=? + (triangle 3 'outline 'red) + (color-list->image + (list white red white + white red white + red white red + red red red) + 3 + 4))) + + (test-case + "triangle2" + (check image=? + (triangle 3 'solid 'red) + (color-list->image + (list white red white + white red white + red red red + red red red) + 3 + 4))) + + (test-case + "clipping-twice-clips-both-times" + (check image=? + (overlay + (rectangle 11 11 'solid 'green) + (clip (rectangle 11 11 'solid 'red) + 5 5 1 1) + "center" "center") + (overlay + (rectangle 11 11 'solid 'green) + (clip (clip (rectangle 11 11 'solid 'red) + 3 3 2 2) + 2 2 1 1) + "center" "center"))) + + (test-case + "solid-rect" + (check-on-bitmap (rectangle 2 2 'solid 'red))) + + (test-case + "outline-rect" + (check-on-bitmap (rectangle 2 2 'outline 'red))) + (test-case + "solid-ellipse" + (check-on-bitmap (ellipse 2 4 'solid 'red))) + (test-case + "outline-ellipse" + (check-on-bitmap (ellipse 2 4 'outline 'red))) + (test-case + "solid-circle" + (check-on-bitmap (circle 4 'solid 'red))) + (test-case + "outline-circle" + (check-on-bitmap (circle 4 'outline 'red))) + + (test-case + "0solid-rect1" + (check-on-bitmap (rectangle 0 2 'solid 'red))) + (test-case + "0solid-rect2" + (check-on-bitmap (rectangle 2 0 'solid 'red))) + (test-case + "0outline-rect1" + (check-on-bitmap (rectangle 2 0 'outline 'red))) + (test-case + "0outline-rect2" + (check-on-bitmap (rectangle 0 0 'outline 'red))) + (test-case + "0solid-ellipse1" + (check-on-bitmap (ellipse 0 3 'solid 'red))) + (test-case + "0solid-ellipse2" + (check-on-bitmap (ellipse 3 0 'solid 'red))) + (test-case + "0outline-ellipse1" + (check-on-bitmap (ellipse 0 4 'outline 'red))) + (test-case + "0outline-ellipse2" + (check-on-bitmap (ellipse 2 0 'outline 'red))) + (test-case + "0solid-circle" + (check-on-bitmap (circle 0 'solid 'red))) + (test-case + "0outline-circle" + (check-on-bitmap (circle 0 'outline 'red))) + + (test-case + "solid-triangle" + (check-on-bitmap (triangle 10 'solid 'red))) + (test-case + "outline-triangle" + (check-on-bitmap (triangle 10 'outline 'red))) + (test-case + "line" + (check-on-bitmap (line 10 7 0 0 9 6 'red))) + + + + ;; (check-on-bitmap 'text (text "XX" 12 'red)) ;; this test fails for reasons I can't control ... -robby + (test-case + "overlay1" + (check-on-bitmap (overlay (rectangle 1 4 'solid 'blue) + (rectangle 4 1 'solid 'green) + "left" "top"))) + (test-case + "overlay2" + (check-on-bitmap (overlay (rectangle 4 4 'solid 'blue) + (rectangle 4 4 'solid 'green) + 2 2))) + (test-case + "overlay3" + (check-on-bitmap (overlay image-snip1 + (rectangle (image-width image-snip1) + (image-height image-snip1) + 'outline + 'red) + "center" "center"))) + (test-case + "alpha-color-list" + (check-on-bitmap + (overlay + (rectangle 3 3 'solid 'blue) + (alpha-color-list->image + (list ared aclr ared + aclr aclr aclr + ared aclr ared) + 3 + 3) + "center" "center"))) + (test-case + "add-line" + (check-on-bitmap + (overlay + (rectangle 100 100 'solid 'black) + (line 100 100 -10 -10 110 110 'red) + 0 0))) + + (test-case + "add-line1" + (check-on-bitmap + (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") + -20 -20 + 0 0 + 'red))) + (test-case + "add-line2" + (check-on-bitmap + (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") + -20 20 + 0 0 + 'red))) + (test-case + "add-line3" + (check-on-bitmap + (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") + 20 -20 + 0 0 + 'red))) + + (test-case + "add-line4" + (check-on-bitmap + (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") + 20 20 + 0 0 + 'red))) + + (test-case + "add-line5" + (check-on-bitmap + (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") + 0 0 + -20 -20 + 'red))) + + (test-case + "add-line6" + (check-on-bitmap + (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") + 0 0 + -20 20 + 'red))) + + (test-case + "add-line7" + (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") + 0 0 + 20 -20 + 'red)) + + (test-case + "add-line8" + (check-on-bitmap + (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") + 0 0 + 20 20 + 'red))) + + (test-case + "shrink" + (check-on-bitmap + (clip (rectangle 11 11 'solid 'red) + 5 5 1 1))) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; test images with zero width or zero height + ;; for various things + ;; + + (test-case + "zero-width/height" + (check-equal? 10 (image-width (rectangle 10 0 'solid 'red))) + (check-equal? 0 (image-height (rectangle 10 0 'solid 'red))) + (check-equal? 0 (image-width (rectangle 0 10 'solid 'red))) + (check-equal? 10 (image-height (rectangle 0 10 'solid 'red))) + + (check-equal? 0 (image-width (text "" 12 'black))) + (check > (image-height (text "" 12 'black)) 0) + + (check-equal? '() (image->color-list (rectangle 0 10 'solid 'red))) + (check-equal? '() (image->color-list (rectangle 10 0 'solid 'red))) + (check-equal? '() (image->color-list (rectangle 0 0 'solid 'red))) + + (check-equal? '() (image->alpha-color-list (rectangle 0 10 'solid 'red))) + (check-equal? '() (image->alpha-color-list (rectangle 10 0 'solid 'red))) + (check-equal? '() (image->alpha-color-list (rectangle 0 0 'solid 'red)))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; test that the image construction functions + ;; accept non-integer values (and floor them) + ;; + + (test-case + "accept-non-integer" + (check-equal? (image->color-list (rectangle 2 2 'solid 'blue)) + (image->color-list (rectangle #e2.5 2.5 'solid 'blue))) + (check-equal? (image->color-list (ellipse 2 2 'solid 'blue)) + (image->color-list (ellipse #e2.5 2.5 'solid 'blue))) + (check-equal? (image->color-list (circle 2 'solid 'blue)) + (image->color-list (circle #e2.5 'solid 'blue))) + (check-equal? (image->color-list (triangle 12 'solid 'blue)) + (image->color-list (triangle 12.5 'solid 'blue))) + (check-equal? (image->color-list (line 10 12 0 0 9 11 'blue)) + (image->color-list (line 10 12 0 0 9.5 #e11.5 'blue))) + (check-equal? (image->color-list (clip (rectangle 10 10 'solid 'blue) 3 3 4 4)) + (image->color-list + (clip (rectangle 10 10 'solid 'blue) + 3.1 + 3.2 + #e4.3 + 4.4))) + (check-equal? (image->color-list (add-line (rectangle 10 10 'solid 'blue) + 0 0 2 2 'red)) + (image->color-list (add-line (rectangle 10 10 'solid 'blue) + 0.1 #e.2 2.1 2.2 'red)))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; The tests beginning with "bs-" ensure + ;; that the operations all can accept bitmap + ;; snips as arguments + ;; + + (test-case + "accept-bitmap" + (check-pred image? image-snip1) + (check-pred image? image-snip2) + (check image=? image-snip1 (send image-snip1 copy)) + (check-not-image=? + ;; They have different masks: + image-snip1 image-snip2) + (check-equal? 2 (image-width image-snip1)) + (check-equal? 2 (image-width image-snip2)) + (check-equal? 2 (image-height image-snip1)) + (check-equal? 2 (image-height image-snip2)) + (check image=? image-snip1 (overlay image-snip1 image-snip2 "center" "center")) + (check image=? image-snip1 (overlay image-snip1 image-snip2 "left" "top")) + (check image=? + (add-line image-snip1 0 0 10 10 'green) + (add-line image-snip2 0 0 10 10 'green)) + (check image-inside? image-snip1 image-snip2) + (check image-inside? image-snip2 image-snip1) + (check-equal? (make-posn 0 0) + (find-image image-snip1 image-snip2)) + (check-equal? (make-posn 0 0) + (find-image image-snip2 image-snip1)) + (check-equal? (image->color-list image-snip1) + (image->color-list image-snip2)) + (check-equal? (image->alpha-color-list image-snip1) + (image->alpha-color-list image-snip2))) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; test image-snip that doesnt' have a bitmap + ;; + + (test-case + "image-snip-no-bitmap" + (check-equal? 20 + (image-width image-snip3)) + (overlay image-snip3 image-snip3 10 10)) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; test color arguments + ;; + (test-case + "color-arguments" + (check-terminates (rectangle 10 10 'solid 'blue)) + (check-terminates (rectangle 10 10 'solid "blue")) + (check-terminates (rectangle 10 10 'solid (make-color 0 0 255))) + (check-terminates (ellipse 10 10 'solid 'blue)) + (check-terminates (ellipse 10 10 'solid "blue")) + (check-terminates (ellipse 10 10 'solid (make-color 0 0 255))) + (check-terminates (circle 10 'solid 'blue)) + (check-terminates (circle 10 'solid "blue")) + (check-terminates (circle 10 'solid (make-color 0 0 255))) + (check-terminates (triangle 10 'solid 'blue)) + (check-terminates (triangle 10 'solid "blue")) + (check-terminates (triangle 10 'solid (make-color 0 0 255))) + (check-terminates (line 10 10 0 0 9 9 'blue)) + (check-terminates (line 10 10 0 0 9 9 "blue")) + (check-terminates (line 10 10 0 0 9 9 (make-color 0 0 255))) + (check-terminates (add-line (rectangle 1 1 'solid 'blue) 0 0 1 1 'blue)) + (check-terminates (add-line (rectangle 1 1 'solid 'blue) 0 0 1 1 "blue")) + (check-terminates (add-line (rectangle 1 1 'solid 'blue) 0 0 1 1 (make-color 0 0 255))) + (check-terminates (text "abc" 12 'blue)) + (check-terminates (text "abc" 12 "blue")) + (check-terminates (text "abc" 12 (make-color 0 0 255)))) + + (test-case + "error-message" + (err/rt-name-test (image-width 1) "first") + (err/rt-name-test (image-height 1) "first") + (err/rt-name-test (overlay 1 2 "center" "center") "first") + (err/rt-name-test (overlay image-snip1 2 "center" "center") "second") + (err/rt-name-test (overlay 1 2 "center" "center") "first") + (err/rt-name-test (overlay image-snip1 image-snip2 "foo" "center") "third") + (err/rt-name-test (overlay image-snip1 image-snip2 "center" "foo") "fourth") + (err/rt-name-test (rectangle #f #f #f #f) "first") + (err/rt-name-test (rectangle 10 #f #f #f) "second") + (err/rt-name-test (rectangle 10 10 #f #f) "third") + (err/rt-name-test (rectangle 10 10 'solid #f) "fourth") + (err/rt-name-test (circle #f #f #f) "first") + (err/rt-name-test (circle 10 #f #f) "second") + (err/rt-name-test (circle 10 'solid #f) "third") + (err/rt-name-test (ellipse #f #f #f #f) "first") + (err/rt-name-test (ellipse 10 #f #f #f) "second") + (err/rt-name-test (ellipse 10 10 #f #f) "third") + (err/rt-name-test (ellipse 10 10 'solid #f) "fourth") + (err/rt-name-test (triangle #f #f #f) "first") + (err/rt-name-test (triangle 10 #f #f) "second") + (err/rt-name-test (triangle 10 'solid #f) "third") + (err/rt-name-test (line #f #f 0 0 0 0 #f) "first") + (err/rt-name-test (line 10 #f 0 0 0 0 #f) "second") + (err/rt-name-test (line 10 10 #f 0 0 0 #f) "third") + (err/rt-name-test (line 10 10 0 #f 0 0 #f) "fourth") + (err/rt-name-test (line 10 10 0 0 #f 0 #f) "fifth") + (err/rt-name-test (line 10 10 0 0 0 #f #f) "sixth") + (err/rt-name-test (line 10 10 0 0 0 0 #f) "seventh") + (err/rt-name-test (text #f #f #f) "first") + (err/rt-name-test (text "abc" #f #f) "second") + (err/rt-name-test (text "abc" 10 #f) "third") + (err/rt-name-test (image-inside? #f #f) "first") + (err/rt-name-test (image-inside? image-snip1 #f) "second") + (err/rt-name-test (find-image #f #f) "first") + (err/rt-name-test (find-image image-snip1 #f) "second") + (err/rt-name-test (image->color-list 1) "first") + (err/rt-name-test (color-list->image #f #f #f) "first") + (err/rt-name-test (color-list->image (list (make-color 0 0 0)) #f #f) "second") + (err/rt-name-test (color-list->image (list (make-color 0 0 0)) 1 #f) "third") + (err/rt-name-test (image->alpha-color-list #f) "first") + (err/rt-name-test (alpha-color-list->image #f #f #f) "first") + (err/rt-name-test (alpha-color-list->image (list (make-alpha-color 0 0 0 0)) #f #f) "second") + (err/rt-name-test (alpha-color-list->image (list (make-alpha-color 0 0 0 0)) 1 #f) "third")) +)) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/tests/match.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/tests/match.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/tests/match.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/tests/match.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,114 @@ +#lang racket/base + +(provide all-match-tests) + +(require rackunit + deinprogramm/DMdA/define-record-procedures + (only-in deinprogramm/DMdA/private/primitives match empty make-pair)) + +(define-record-procedures pare + kons pare? + (kar kdr)) + +(define-record-procedures bare + gons bare? + (gar gdr)) + +(define-record-procedures nullary + make-nullary nullary? + ()) + +(define all-match-tests + (test-suite + "Tests for DeinProgramm match form." + + (test-case + "literals" + (define foo + (lambda (x) + (match x + (#t 'true) + (#f 'false) + ('() 'nil) + ('(foo bar) 'foobar) + ("foo" 'foo) + ("bar" 'bar) + (5 'five) + (2 'two)))) + + (check-equal? (foo #t) 'true) + (check-equal? (foo #f) 'false) + (check-equal? (foo '()) 'nil) + (check-equal? (foo '(foo bar)) 'foobar) + (check-equal? (foo "foo") 'foo) + (check-equal? (foo "bar") 'bar) + (check-equal? (foo 5) 'five) + (check-equal? (foo 2) 'two)) + + + (test-case + "variables" + (define foo + (lambda (x) + (match x + (#t 'true) + (foo (list 'foo foo))))) + (check-equal? (foo #t) 'true) + (check-equal? (foo "foo") '(foo "foo"))) + + (test-case + "lists" + (define foo + (lambda (x) + (match x + (empty 'empty) + ((make-pair 'foo empty) 'fooempty) + ((list 'foo 'bar) 'listfoobar) + ((list 'bar 'foo) 'listbarfoo) + ((list a b c) (list 'list a b c)) + ((make-pair 5 b) (list 'make-pair5 b)) + ((make-pair a (make-pair b c)) (list 'make-pair a b c)) + ((make-pair a b) (list 'make-pair a b)) + (x (list 'x x))))) + + (check-equal? (foo empty) 'empty) + (check-equal? (foo "empty") '(x "empty")) + (check-equal? (foo (list 1 2 3)) '(list 1 2 3)) + (check-equal? (foo (make-pair 'foo empty)) 'fooempty) + (check-equal? (foo (make-pair 1 empty)) '(make-pair 1 ())) + (check-equal? (foo (make-pair 5 empty)) '(make-pair5 ())) + (check-equal? (foo (list 1 2)) '(make-pair 1 2 ())) + (check-equal? (match empty ((list) 'bingo)) 'bingo) + (check-equal? (match (list 1) ((list) 'bingo) (foo foo)) (list 1)) + (check-equal? (foo (list 'foo 'bar)) 'listfoobar) + (check-equal? (foo (list 'bar 'foo)) 'listbarfoo)) + + (test-case + "anything" + (check-equal? (match 5 (_ 7)) 7) + (check-equal? (match '(1 2) (_ 7)) 7) + (check-equal? (match #f (_ 7)) 7) + (check-equal? (let ((_ 5)) (match #f (_ _))) 5) + (check-equal? (match #f + ((kons _ _) 7) + (_ 5)) + 5) + (check-equal? (match (kons 1 2) + ((kons _ _) 7) + (_ 5)) + 7)) + + (test-case + "records" + (define foo + (lambda (x) + (match x + ((make-pair foo empty) 'pairfoo) + ((make-nullary) 'nullary) + ((kons a b) (list 'kons a b)) + ((gons a b) (list 'gons a b))))) + + (check-equal? (foo (make-pair foo empty)) 'pairfoo) + (check-equal? (foo (make-nullary)) 'nullary) + (check-equal? (foo (kons 1 2)) '(kons 1 2)) + (check-equal? (foo (gons 1 2)) '(gons 1 2))))) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/tests/record.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/tests/record.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/tests/record.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/tests/record.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,125 @@ +#lang racket/base + +(provide all-record-tests) + +(require rackunit + deinprogramm/DMdA/define-record-procedures + deinprogramm/signature/signature-syntax + (only-in deinprogramm/signature/signature signature?) + racket/match) + +(define-record-procedures pare + kons pare? + (kar kdr)) + +(define-record-procedures paire + koins + (kair kdir)) + +(define-record-procedures chocolate-cookie + make-chocolate-cookie chocolate-cookie? + (chocolate-cookie-chocolate chocolate-cookie-cookie)) + +(define-record-procedures-2 mpare + mkons mpare? + ((mkar set-mkar!) mkdr)) + +(define any (signature any %any)) + +(define-record-procedures (ppare a) + pkons pkons? + ((pkar a) + (pkdr any))) + +; (: pkons (%a any -> (pkons %a))) + +(define-record-procedures-parametric pppare ppkons-of + ppkons ppkons? + (ppkar ppkdr)) + +(define-record-procedures-parametric-2 pmpare pmkons-of + pmkons pmkons? + ((pmkar set-pmkar!) pmkdr)) + +(define all-record-tests + (test-suite + "Tests for DeinProgramm records." + + (test-case + "basics" + (define p1 (kons 1 2)) + (define p2 (kons 3 4)) + + (check-true (pare? p1)) + (check-true (pare? p2)) + + (check-false (pare? 5)) + (check-false (pare? (make-chocolate-cookie 1 2))) + + (check-equal? (kar p1) 1) + (check-equal? (kdr p1) 2) + (check-equal? (kar p2) 3) + (check-equal? (kdr p2) 4)) + + (test-case + "no predicate" + + (define p1 (koins 1 2)) + (define p2 (koins 3 4)) + + (check-equal? (kair p1) 1) + (check-equal? (kdir p1) 2) + (check-equal? (kair p2) 3) + (check-equal? (kdir p2) 4) + + (check-true (signature? paire))) + + (test-case + "matching" + (define p (kons 1 2)) + (define c (make-chocolate-cookie 3 4)) + + (define t + (lambda (r) + (match r + ((kons a b) (list 'kons a b)) + ((make-chocolate-cookie ch ck) (list 'make-chocolate-cookie ch ck))))) + + (check-equal? (t p) '(kons 1 2)) + (check-equal? (t c) '(make-chocolate-cookie 3 4))) + + (test-case + "parametric" + (define p (pkons 1 2)) + + (check-equal? (pkar p) 1) + (check-equal? (pkdr p) 2)) + + (test-case + "-2" + (define p (mkons 1 2)) + + (check-equal? (mkar p) 1) + (check-equal? (mkdr p) 2) + + (set-mkar! p 5) + + (check-equal? (mkar p) 5)) + + (test-case + "-parametric" + (define p (ppkons 1 2)) + + (check-equal? (ppkar p) 1) + (check-equal? (ppkdr p) 2)) + + (test-case + "-parametric-2" + (define p (pmkons 1 2)) + + (check-equal? (pmkar p) 1) + (check-equal? (pmkdr p) 2) + + (set-pmkar! p 5) + + (check-equal? (pmkar p) 5)))) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/tests/run-image-test.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/tests/run-image-test.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/tests/run-image-test.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/tests/run-image-test.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,6 @@ +#lang scheme/base + +(require rackunit/text-ui) +(require deinprogramm/DMdA/tests/image) + +(run-tests all-image-tests) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/tests/run-match-tests.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/tests/run-match-tests.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/tests/run-match-tests.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/tests/run-match-tests.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,6 @@ +#lang racket/base + +(require rackunit/text-ui) +(require deinprogramm/DMdA/tests/match) + +(run-tests all-match-tests) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/tests/run-record-tests.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/tests/run-record-tests.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/tests/run-record-tests.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/tests/run-record-tests.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,6 @@ +#lang racket/base + +(require rackunit/text-ui) +(require deinprogramm/DMdA/tests/record) + +(run-tests all-record-tests) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/tests/run-signature-tests.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/tests/run-signature-tests.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/tests/run-signature-tests.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/tests/run-signature-tests.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,6 @@ +#lang scheme/base + +(require rackunit/text-ui) +(require deinprogramm/DMdA/tests/signature) + +(run-tests all-signature-tests) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/tests/signature.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/tests/signature.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA/tests/signature.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA/tests/signature.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,645 @@ +#lang scheme/base + +(provide all-signature-tests) + +(require rackunit + deinprogramm/DMdA/define-record-procedures + deinprogramm/signature/signature + deinprogramm/signature/signature-german + deinprogramm/signature/signature-syntax) + +(require scheme/promise) + +(define integer (make-predicate-signature 'integer integer? 'integer-marker)) +(define boolean (make-predicate-signature 'boolean boolean? 'boolean-marker)) +(define %a (make-type-variable-signature 'a 'a-marker)) +(define %b (make-type-variable-signature 'b 'b-marker)) + +(define-syntax say-no + (syntax-rules () + ((say-no ?body ...) + (let/ec exit + (call-with-signature-violation-proc + (lambda (obj signature message blame) + (exit 'no)) + (lambda () + ?body ...)))))) + +(define-syntax failed-signature + (syntax-rules () + ((say-no ?body ...) + (let/ec exit + (call-with-signature-violation-proc + (lambda (obj signature message blame) + (exit signature)) + (lambda () + ?body ...)))))) + +(define signature-tests + (test-suite + "Tests for signature combinators" + + (test-case + "flat" + (check-equal? (say-no (apply-signature integer 5)) 5) + (check-equal? (say-no (apply-signature integer "foo")) 'no)) + + (test-case + "list" + (define integer-list (make-list-signature 'integer-list integer #f)) + (check-equal? (say-no (apply-signature integer-list '(1 2 3))) + '(1 2 3)) + (check-equal? (say-no (apply-signature integer-list '#f)) + 'no) + (check-eq? (failed-signature (apply-signature integer-list '(1 #f 3))) + integer)) + + (test-case + "list-cached" + (define integer-list (make-list-signature 'integer-list integer #f)) + (define boolean-list (make-list-signature 'integer-list boolean #f)) + (define l '(1 2 3)) + (define foo "foo") + (define no '(1 #f 3)) + (define no2 '(1 #f 3)) + (define integer-list->bool (make-procedure-signature 'integer-list->bool (list integer-list) boolean 'int->bool-marker)) + + (check-equal? (say-no (apply-signature integer-list l)) + '(1 2 3)) + (check-equal? (say-no (apply-signature integer-list l)) + '(1 2 3)) + (check-equal? (say-no (apply-signature boolean-list l)) + 'no) + (check-equal? (say-no (apply-signature integer-list foo)) + 'no) + (check-equal? (say-no (apply-signature integer-list foo)) + 'no) + (check-eq? (failed-signature (apply-signature integer-list no)) + integer) + (check-eq? (failed-signature (apply-signature integer-list no)) + integer) + + (let ((proc (say-no (apply-signature integer-list->bool (lambda (l) (even? (car l))))))) + (check-equal? (say-no (proc no)) 'no) + (check-equal? (say-no (proc no)) 'no) + (check-equal? (say-no (proc no2)) 'no) + (check-equal? (say-no (proc no2)) 'no)) + ) + + (test-case + "vector" + (define integer-vector (make-vector-signature 'integer-vector integer #f)) + (define a-vector (make-vector-signature 'a-vector %a #f)) + (check-equal? (say-no (apply-signature integer-vector '#(1 2 3))) + '#(1 2 3)) + (check-equal? (say-no (apply-signature a-vector '#(1 2 3))) + '#(1 2 3)) + (check-equal? (say-no (apply-signature integer-vector '#f)) + 'no) + (check-eq? (failed-signature (apply-signature integer-vector '#(1 #f 3))) + integer)) + + (test-case + "vector/cached" + (let ((count 0)) + (define counting-integer + (make-predicate-signature 'counting-integer + (lambda (obj) + (set! count (+ 1 count)) + (integer? obj)) + 'integer-marker)) + + (define integer-vector (make-vector-signature 'integer-list counting-integer #f)) + + (define v1 '#(1 2 3)) + + (check-eq? (say-no (apply-signature integer-vector v1)) + v1) + (check-equal? count 3) + (check-eq? (say-no (apply-signature integer-vector v1)) + v1) + (check-equal? count 3))) + + + (test-case + "mixed" + (define int-or-bool (make-mixed-signature 'int-or-bool + (list integer + boolean) + 'int-or-bool-marker)) + (check-equal? (say-no (apply-signature int-or-bool #f)) + #f) + (check-equal? (say-no (apply-signature int-or-bool 17)) + 17) + (check-equal? (say-no (apply-signature int-or-bool "foo")) + 'no)) + + (test-case + "combined" + (define octet (make-combined-signature + 'octet + (list + integer + (make-predicate-signature '<256 + (delay (lambda (x) + (< x 256))) + '<256-marker) + (make-predicate-signature 'non-negative + (delay (lambda (x) + (>= x 0))) + 'non-negative-marker)) + 'octet-marker)) + (check-equal? (say-no (apply-signature octet #f)) + 'no) + (check-equal? (say-no (apply-signature octet 17)) + 17) + (check-equal? (say-no (apply-signature octet 0)) + 0) + (check-equal? (say-no (apply-signature octet -1)) + 'no) + (check-equal? (say-no (apply-signature octet 255)) + 255) + (check-equal? (say-no (apply-signature octet 256)) + 'no) + (check-equal? (say-no (apply-signature octet "foo")) + 'no)) + + (test-case + "case" + (define foo-or-bar (make-case-signature 'foo-or-bar '("foo" "bar") equal? 'foo-or-bar-marker)) + (check-equal? (say-no (apply-signature foo-or-bar #f)) + 'no) + (check-equal? (say-no (apply-signature foo-or-bar "foo")) + "foo") + (check-equal? (say-no (apply-signature foo-or-bar "bar")) + "bar")) + + (test-case + "procedure" + (define int->bool (make-procedure-signature 'int->bool (list integer) boolean 'int->bool-marker)) + (check-equal? (say-no (apply-signature int->bool #f)) + 'no) + (check-equal? (say-no (apply-signature int->bool (lambda () "foo"))) + 'no) + (check-equal? (say-no (apply-signature int->bool (lambda (x y) "foo"))) + 'no) + (let ((proc (say-no (apply-signature int->bool (lambda (x) (odd? x)))))) + (check-pred procedure? proc) + (check-equal? (proc 15) #t) + (check-equal? (proc 16) #f) + (check-equal? (say-no (proc "foo")) 'no)) + (let ((proc (say-no (apply-signature int->bool (lambda (x) (+ x 1)))))) + (check-equal? (say-no (proc 12)) 'no))) + + (test-case + "type variable - simple" + (check-equal? (say-no (apply-signature %a #f)) #f) + (check-equal? (say-no (apply-signature %a 15)) 15)) + + (test-case + "type variable - list" + (define a-list (make-list-signature 'a-list %a #f)) + (check-equal? (say-no (apply-signature a-list '(1 2 3))) + '(1 2 3)) + (check-equal? (say-no (apply-signature a-list '#f)) + 'no) + (check-equal? (say-no (apply-signature a-list '(#f "foo" 5))) + '(#f "foo" 5))) + + (test-case + "apply-signature/blame" + (define int->bool (make-procedure-signature 'int->bool (list integer) boolean 'int->bool-marker)) + (let ((proc (say-no (apply-signature/blame int->bool (lambda (x) (odd? x)))))) + (check-pred procedure? proc) + (check-equal? (proc 15) #t) + (check-equal? (proc 16) #f) + (check-equal? (say-no (proc "foo")) 'no)) + (let ((proc (say-no (apply-signature/blame int->bool (lambda (x) x))))) + (call-with-signature-violation-proc + (lambda (obj signature message blame) + (check-true (syntax? blame))) + (lambda () + (proc 5))))) + )) + +(define signature-syntax-tests + (test-suite + "Tests for signature syntax" + + (test-case + "predicate" + (define integer (signature (predicate integer?))) + (check-equal? (say-no (apply-signature integer 5)) 5) + (check-equal? (say-no (apply-signature integer "foo")) 'no)) + + (test-case + "list" + (check-equal? (say-no (apply-signature (signature x (list-of %a)) 5)) 'no) + (check-equal? (say-no (apply-signature (signature x (list-of %a)) '(1 2 3))) '(1 2 3)) + (check-equal? (say-no (apply-signature (signature x (list-of (predicate integer?))) '(1 2 3))) '(1 2 3)) + (check-equal? (say-no (apply-signature (signature x (list-of (predicate integer?))) '(1 #f 3))) 'no)) + + (test-case + "mixed" + (define int-or-bool (signature (mixed integer boolean))) + (check-equal? (say-no (apply-signature int-or-bool #f)) + #f) + (check-equal? (say-no (apply-signature int-or-bool 17)) + 17) + (check-equal? (say-no (apply-signature int-or-bool "foo")) + 'no)) + + (test-case + "combined" + (define octet (signature (combined integer + (predicate (lambda (x) + (< x 256))) + (predicate (lambda (x) + (>= x 0)))))) + (check-equal? (say-no (apply-signature octet #f)) + 'no) + (check-equal? (say-no (apply-signature octet 17)) + 17) + (check-equal? (say-no (apply-signature octet 0)) + 0) + (check-equal? (say-no (apply-signature octet -1)) + 'no) + (check-equal? (say-no (apply-signature octet 255)) + 255) + (check-equal? (say-no (apply-signature octet 256)) + 'no) + (check-equal? (say-no (apply-signature octet "foo")) + 'no)) + + (test-case + "procedure" + (define int->bool (signature int->bool ((predicate integer?) -> (predicate boolean?)))) + (check-equal? (say-no (apply-signature int->bool #f)) + 'no) + (check-equal? (say-no (apply-signature int->bool (lambda () "foo"))) + 'no) + (check-equal? (say-no (apply-signature int->bool (lambda (x y) "foo"))) + 'no) + (let ((proc (say-no (apply-signature int->bool (lambda (x) (odd? x)))))) + (check-pred procedure? proc) + (check-equal? (proc 15) #t) + (check-equal? (proc 16) #f) + (check-equal? (say-no (proc "foo")) 'no)) + (let ((proc (say-no (apply-signature int->bool (lambda (x) (+ x 1)))))) + (check-equal? (say-no (proc 12)) 'no))) + + + (test-case + "record-wrap" + (define-record-procedures-parametric pare pare-of kons pare? (kar kdr)) + (define ctr (pare-of integer boolean)) + (let ((obj (apply-signature ctr (kons 1 #t)))) + (check-equal? (kar obj) 1) + (check-equal? (kdr obj) #t)) + (check-equal? (say-no (apply-signature ctr (kons 1 2))) 'no) + ) + + (test-case + "record-wrap/lazy" + (define-struct pare (kar kdr extra) + #:mutable + #:property prop:lazy-wrap + (make-lazy-wrap-info + (lambda (kar kdr) (kons kar kdr)) + (list (lambda (x) (pare-kar x)) (lambda (x) (pare-kdr x))) + (list (lambda (x v) (set-pare-kar! x v)) + (lambda (x v) (set-pare-kdr! x v))) + (lambda (x) (pare-extra x)) (lambda (x v) (set-pare-extra! x v)))) + (define (kons kar kdr) + (make-pare kar kdr #f)) + (define (kar p) + (check-lazy-wraps! struct:pare p) + (pare-kar p)) + (define (kdr p) + (check-lazy-wraps! struct:pare p) + (pare-kdr p)) + (define (pare-of kar-sig kdr-sig) + (make-lazy-wrap-signature 'pare #f + struct:pare + pare? + (list kar-sig kdr-sig) + #f)) + (define ctr (pare-of integer boolean)) + (let ((obj (apply-signature ctr (kons 1 #t)))) + (check-equal? (kar obj) 1) + (check-equal? (kdr obj) #t)) + (let ((obj (apply-signature ctr (kons 1 2)))) + (check-equal? (say-no (kar obj)) 'no)) + ) + + (test-case + "record-wrap-2" + (let ((count 0)) + (define counting-integer + (make-predicate-signature 'counting-integer + (lambda (obj) + (set! count (+ 1 count)) + (integer? obj)) + 'integer-marker)) + (define-record-procedures-parametric pare pare-of kons pare? (kar kdr)) + (define ctr (signature (pare-of counting-integer boolean))) + (let ((obj (apply-signature ctr (apply-signature ctr (kons 1 #t))))) + (check-equal? count 1) + (check-equal? (kar obj) 1) + (check-equal? count 1) + (check-equal? (kdr obj) #t) + (check-equal? count 1)))) + + (test-case + "record-wrap-2/lazy" + (let ((count 0)) + (define counting-integer + (make-predicate-signature 'counting-integer + (lambda (obj) + (set! count (+ 1 count)) + (integer? obj)) + 'integer-marker)) + + (define-struct pare (kar kdr extra) + #:mutable + #:property prop:lazy-wrap + (make-lazy-wrap-info + (lambda (kar kdr) (kons kar kdr)) + (list (lambda (x) (pare-kar x)) (lambda (x) (pare-kdr x))) + (list (lambda (x v) (set-pare-kar! x v)) + (lambda (x v) (set-pare-kdr! x v))) + (lambda (x) (pare-extra x)) (lambda (x v) (set-pare-extra! x v)))) + (define (kons kar kdr) + (make-pare kar kdr #f)) + (define (kar p) + (check-lazy-wraps! struct:pare p) + (pare-kar p)) + (define (kdr p) + (check-lazy-wraps! struct:pare p) + (pare-kdr p)) + (define (pare-of kar-sig kdr-sig) + (make-lazy-wrap-signature 'pare #f + struct:pare + pare? + (list kar-sig kdr-sig) + #f)) + + (define ctr (signature (pare-of counting-integer boolean))) + (let ((obj (apply-signature ctr (apply-signature ctr (kons 1 #t))))) + (check-equal? count 0) + (check-equal? (kar obj) 1) + (check-equal? count 1) + (check-equal? (kdr obj) #t) + (check-equal? count 1)))) + + (test-case + "record-wrap-3" + (let ((count 0)) + (define counting-integer + (make-predicate-signature 'counting-integer + (lambda (obj) + (set! count (+ 1 count)) + (integer? obj)) + 'integer-marker)) + + (define-record-procedures-parametric pare pare-of kons pare? (kar kdr)) + (define ctr (signature (pare-of counting-integer boolean))) + (let ((obj (apply-signature ctr (apply-signature ctr (kons 1 #t))))) + (check-equal? count 1) + (check-equal? (kar obj) 1) + (check-equal? count 1) + (check-equal? (kdr obj) #t) + (check-equal? count 1) + ;; after checking, the system should remember that it did so + (let ((obj-2 (apply-signature ctr obj))) + (check-equal? count 1) + (check-equal? (kar obj) 1) + (check-equal? count 1) + (check-equal? (kdr obj) #t) + (check-equal? count 1))))) + + (test-case + "record-wrap-3/lazy" + (let ((count 0)) + (define counting-integer + (make-predicate-signature 'counting-integer + (lambda (obj) + (set! count (+ 1 count)) + (integer? obj)) + 'integer-marker)) + (define-struct pare (kar kdr extra) + #:mutable + #:property prop:lazy-wrap + (make-lazy-wrap-info + (lambda (kar kdr) (kons kar kdr)) + (list (lambda (x) (pare-kar x)) (lambda (x) (pare-kdr x))) + (list (lambda (x v) (set-pare-kar! x v)) + (lambda (x v) (set-pare-kdr! x v))) + (lambda (x) (pare-extra x)) (lambda (x v) (set-pare-extra! x v)))) + (define (kons kar kdr) + (make-pare kar kdr #f)) + (define (kar p) + (check-lazy-wraps! struct:pare p) + (pare-kar p)) + (define (kdr p) + (check-lazy-wraps! struct:pare p) + (pare-kdr p)) + (define (pare-of kar-sig kdr-sig) + (make-lazy-wrap-signature 'pare #f + struct:pare + pare? + (list kar-sig kdr-sig) + #f)) + + (define ctr (signature (pare-of counting-integer boolean))) + (let ((obj (apply-signature ctr (apply-signature ctr (kons 1 #t))))) + (check-equal? count 0) + (check-equal? (kar obj) 1) + (check-equal? count 1) + (check-equal? (kdr obj) #t) + (check-equal? count 1) + ;; after checking, the system should remember that it did so + (let ((obj-2 (apply-signature ctr obj))) + (check-equal? count 1) + (check-equal? (kar obj) 1) + (check-equal? count 1) + (check-equal? (kdr obj) #t) + (check-equal? count 1))))) + + (test-case + "double-wrap" + (let ((count 0)) + (define counting-integer + (make-predicate-signature 'counting-integer + (lambda (obj) + (set! count (+ 1 count)) + (integer? obj)) + 'integer-marker)) + (define-record-procedures-parametric pare pare-of raw-kons pare? (kar kdr)) + + (define empty-list (signature (predicate null?))) + + (define my-list-of + (lambda (x) + (signature (mixed empty-list + (pare-of x (my-list-of x)))))) + + (define/signature kons (signature (%a (my-list-of %a) -> (pare-of %a (my-list-of %a)))) + raw-kons) + + (define/signature build-list (signature (integer -> (my-list-of counting-integer))) + (lambda (n) + (if (= n 0) + '() + (kons n (build-list (- n 1)))))) + + (define/signature list-length (signature ((my-list-of counting-integer) -> integer)) + (lambda (lis) + (cond + ((null? lis) 0) + ((pare? lis) + (+ 1 (list-length (kdr lis))))))) + + ;; one wrap each for (my-list-of %a), one for (my-list-of counting-integer) + (let ((l1 (build-list 10))) + (check-equal? count 10) + (let ((len1 (list-length l1))) + (check-equal? count 10))))) + + (test-case + "double-wrap/lazy" + (let ((count 0)) + (define counting-integer + (make-predicate-signature 'counting-integer + (lambda (obj) + (set! count (+ 1 count)) + (integer? obj)) + 'integer-marker)) + + (define-struct pare (kar kdr extra) + #:mutable + #:property prop:lazy-wrap + (make-lazy-wrap-info + (lambda (kar kdr) (raw-kons kar kdr)) + (list (lambda (x) (pare-kar x)) (lambda (x) (pare-kdr x))) + (list (lambda (x v) (set-pare-kar! x v)) + (lambda (x v) (set-pare-kdr! x v))) + (lambda (x) (pare-extra x)) (lambda (x v) (set-pare-extra! x v)))) + (define (raw-kons kar kdr) + (make-pare kar kdr #f)) + (define (kar p) + (check-lazy-wraps! struct:pare p) + (pare-kar p)) + (define (kdr p) + (check-lazy-wraps! struct:pare p) + (pare-kdr p)) + (define (pare-of kar-sig kdr-sig) + (make-lazy-wrap-signature 'pare #f + struct:pare + pare? + (list kar-sig kdr-sig) + #f)) + + + (define empty-list (signature (predicate null?))) + + (define my-list-of + (lambda (x) + (signature (mixed empty-list + (pare-of x (my-list-of x)))))) + + (define/signature kons (signature (%a (my-list-of %a) -> (pare-of %a (my-list-of %a)))) + raw-kons) + + (define/signature build-list (signature (integer -> (my-list-of counting-integer))) + (lambda (n) + (if (= n 0) + '() + (kons n (build-list (- n 1)))))) + + (define/signature list-length (signature ((my-list-of counting-integer) -> integer)) + (lambda (lis) + (cond + ((null? lis) 0) + ((pare? lis) + (+ 1 (list-length (kdr lis))))))) + + ;; one wrap each for (my-list-of %a), one for (my-list-of counting-integer) + (let ((l1 (build-list 10))) + (check-equal? count 0) + (let ((len1 (list-length l1))) + (check-equal? count 10))))) + + (test-case + "mixed wrap" + + (define-struct pare (kar kdr extra) + #:mutable + #:property prop:lazy-wrap + (make-lazy-wrap-info + (lambda (kar kdr) (raw-kons kar kdr)) + (list (lambda (x) (pare-kar x)) (lambda (x) (pare-kdr x))) + (list (lambda (x v) (set-pare-kar! x v)) + (lambda (x v) (set-pare-kdr! x v))) + (lambda (x) (pare-extra x)) (lambda (x v) (set-pare-extra! x v)))) + (define (raw-kons kar kdr) + (make-pare kar kdr #f)) + (define (kar p) + (check-lazy-wraps! struct:pare p) + (pare-kar p)) + (define (kdr p) + (check-lazy-wraps! struct:pare p) + (pare-kdr p)) + (define (pare-of kar-sig kdr-sig) + (make-lazy-wrap-signature 'pare #f + struct:pare + pare? + (list kar-sig kdr-sig) + #f)) + + + (define sig1 (signature (pare-of integer boolean))) + (define sig2 (signature (pare-of boolean integer))) + (define sig (signature (mixed sig1 sig2))) + (define/signature x sig (raw-kons #t 15)) + (define/signature y sig (raw-kons #t #t)) + (check-equal? (kar x) #t) + (check-equal? (say-no (kar y)) 'no)) + + (test-case + "wrap equality" + (define-record-procedures-parametric pare pare-of raw-kons pare? (kar kdr)) + + (define empty-list (signature (predicate null?))) + + (define my-list-of + (lambda (x) + (signature (mixed empty-list + (pare-of x (my-list-of x)))))) + + (define/signature kons (signature (%a (my-list-of %a) -> (pare-of %a (my-list-of %a)))) + raw-kons) + + (check-equal? (raw-kons 1 '()) (raw-kons 1 '())) + (check-equal? (kons 1 '()) (kons 1 '())) + (check-equal? (kons 1 '()) (raw-kons 1 '())) + (check-equal? (raw-kons 1 '()) (kons 1 '()))) + + (test-case + "pair-wrap" + (define sig (make-pair-signature #f integer boolean)) + (let ((obj (apply-signature sig (cons 1 #t)))) + (check-equal? (checked-car obj) 1) + (check-equal? (checked-cdr obj) #t)) + (let ((obj (apply-signature sig (cons 1 2)))) + (check-equal? (say-no (checked-car obj)) 'no)) + ) + +)) + + +(define all-signature-tests + (test-suite + "all-signature-tests" + signature-tests + signature-syntax-tests)) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA-advanced-reader.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA-advanced-reader.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA-advanced-reader.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA-advanced-reader.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1,5 +1,5 @@ #lang scheme/base -(require deinprogramm/DMdA-reader) +(require deinprogramm/DMdA/private/DMdA-reader) (provide (rename-out (-read-syntax read-syntax)) (rename-out (-read read))) (define -read-syntax (make-read-syntax '(lib "DMdA-advanced.ss" "deinprogramm"))) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA-advanced.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA-advanced.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA-advanced.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA-advanced.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -15,5 +15,5 @@ number real rational integer natural boolean true false string symbol empty-list unspecific any property) (provide-and-document procedures - (all-from advanced: deinprogramm/DMdA procedures)) + (all-from advanced: deinprogramm/DMdA/private/primitives procedures)) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA-assignments-reader.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA-assignments-reader.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA-assignments-reader.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA-assignments-reader.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1,6 +1,6 @@ #lang scheme/base -(require deinprogramm/DMdA-reader) +(require deinprogramm/DMdA/private/DMdA-reader) (provide (rename-out (-read-syntax read-syntax)) (rename-out (-read read))) -(define -read-syntax (make-read-syntax '(lib "DMdA-assignments.ss" "deinprogramm"))) -(define -read (make-read '(lib "DMdA-assignments.ss" "deinprogramm"))) +(define -read-syntax (make-read-syntax '(lib "DMdA-assignments.rkt" "deinprogramm"))) +(define -read (make-read '(lib "DMdA-assignments.rkt" "deinprogramm"))) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA-assignments.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA-assignments.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA-assignments.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA-assignments.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -15,7 +15,7 @@ number real rational integer natural boolean true false string empty-list unspecific any property) (provide-and-document procedures - (all-from-except assignments: deinprogramm/DMdA procedures + (all-from-except assignments: deinprogramm/DMdA/private/primitives procedures quote symbol? symbol=? string->symbol symbol->string)) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA-beginner-reader.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA-beginner-reader.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA-beginner-reader.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA-beginner-reader.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1,5 +1,5 @@ #lang scheme/base -(require deinprogramm/DMdA-reader) +(require deinprogramm/DMdA/private/DMdA-reader) (provide (rename-out (-read-syntax read-syntax)) (rename-out (-read read))) (define -read-syntax (make-read-syntax '(lib "DMdA-beginner.rkt" "deinprogramm"))) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA-beginner.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA-beginner.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA-beginner.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA-beginner.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -13,7 +13,7 @@ number real rational integer natural boolean true false string empty-list any property) (provide-and-document procedures - (all-from-except beginner: deinprogramm/DMdA procedures + (all-from-except beginner: deinprogramm/DMdA/private/primitives procedures set! define-record-procedures-2 eq? equal? quote make-pair pair? cons? first rest Binary files /tmp/tmp0gsW68/xZwWv_wqW8/racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/dmda-logo.png and /tmp/tmp0gsW68/cUaTt6TkRm/racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/dmda-logo.png differ diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA-reader.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA-reader.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA-reader.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA-reader.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,45 +0,0 @@ -#lang scheme/base - - (require mzlib/etc) - (provide make-read-syntax - make-read) - - (define (make-read spec) - (let ([read - (opt-lambda ([port (current-input-port)]) - (syntax->datum ((make-read-syntax spec) 'whatever port)))]) - read)) - - (define (get-all-exps source-name port) - (let loop () - (let ([exp (read-syntax source-name port)]) - (cond - [(eof-object? exp) null] - [else (cons exp (loop))])))) - - (define (lookup key table) - (let ([ans (assoc key table)]) - (unless ans - (error 'special-reader "couldn't find ~s in table ~s" - key table)) - (cadr ans))) - - (define (make-read-syntax spec) - (let ([read-syntax - (opt-lambda ([source-name #f] - [port (current-input-port)]) - (let* ([table (read port)] - [path (object-name port)] - [modname - (if (path-string? path) - (let-values ([(base name dir) (split-path path)]) - (string->symbol (path->string (path-replace-suffix name #"")))) - (lookup 'modname table))]) - (datum->syntax - #f - `(module ,modname ,spec - ,@(map (lambda (x) `(require ,x)) - (lookup 'teachpacks table)) - ,@(parameterize ([read-case-sensitive (lookup 'read-case-sensitive table)]) - (get-all-exps source-name port))))))]) - read-syntax)) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,1296 +0,0 @@ -#lang scheme/base - -(require syntax/docprovide) - -(require test-engine/scheme-tests - (lib "test-info.scm" "test-engine") - test-engine/scheme-tests - scheme/class) - -(require deinprogramm/signature/module-begin - (except-in deinprogramm/signature/signature signature-violation) - (except-in deinprogramm/signature/signature-syntax property)) - -(require (for-syntax scheme/base) - (for-syntax stepper/private/syntax-property) - (for-syntax syntax/parse) - (for-syntax racket/struct-info) - syntax/parse) - -(require deinprogramm/define-record-procedures) - -(require (only-in lang/private/teachprims define-teach teach-equal? beginner-equal~?)) - -(require (for-syntax deinprogramm/syntax-checkers)) - -(require (rename-in deinprogramm/quickcheck/quickcheck - (property quickcheck:property))) - -(provide provide lib planet rename-out require #%datum #%module-begin #%top-interaction) ; so we can use this as a language - -(provide (all-from-out deinprogramm/define-record-procedures)) -(provide (all-from-out test-engine/scheme-tests)) -(provide signature define-contract : - contract ; legacy - -> mixed one-of predicate combined list-of) - -(provide number real rational integer natural - boolean true false - string symbol - empty-list - unspecific - any - property) - -(provide match) - -(define-syntax provide/rename - (syntax-rules () - ((provide/rename (here there) ...) - (begin - (provide (rename-out (here there))) ...)))) - -(provide/rename - (DMdA-define define) - (DMdA-let let) - (DMdA-let* let*) - (DMdA-letrec letrec) - (DMdA-lambda lambda) - (DMdA-lambda λ) - (DMdA-cond cond) - (DMdA-if if) - (DMdA-else else) - (DMdA-begin begin) - (DMdA-and and) - (DMdA-or or) - (DMdA-dots ..) - (DMdA-dots ...) - (DMdA-dots ....) - (DMdA-dots .....) - (DMdA-dots ......) - (DMdA-app #%app) - (DMdA-top #%top) - (DMdA-set! set!) - (module-begin DMdA-module-begin)) - -(provide DMdA-advanced-lambda - DMdA-advanced-define) - -(provide for-all ==> - check-property - expect expect-within expect-member-of expect-range) - -(provide quote) - -(provide-and-document - procedures - ("Zahlen" - (number? (any -> boolean) - "feststellen, ob ein Wert eine Zahl ist") - - (= (number number number ... -> boolean) - "Zahlen auf Gleichheit testen") - (< (real real real ... -> boolean) - "Zahlen auf kleiner-als testen") - (> (real real real ... -> boolean) - "Zahlen auf größer-als testen") - (<= (real real real ... -> boolean) - "Zahlen auf kleiner-gleich testen") - (>= (real real real ... -> boolean) - "Zahlen auf größer-gleich testen") - - (+ (number number number ... -> number) - "Summe berechnen") - (- (number number ... -> number) - "bei mehr als einem Argument Differenz zwischen der ersten und der Summe aller weiteren Argumente berechnen; bei einem Argument Zahl negieren") - (* (number number number ... -> number) - "Produkt berechnen") - (/ (number number number ... -> number) - "das erste Argument durch das Produkt aller weiteren Argumente berechnen") - (max (real real ... -> real) - "Maximum berechnen") - (min (real real ... -> real) - "Minimum berechnen") - (quotient (integer integer -> integer) - "ganzzahlig dividieren") - (remainder (integer integer -> integer) - "Divisionsrest berechnen") - (modulo (integer integer -> integer) - "Divisionsmodulo berechnen") - (sqrt (number -> number) - "Quadratwurzel berechnen") - (expt (number number -> number) - "Potenz berechnen (erstes Argument hoch zweites Argument)") - (abs (real -> real) - "Absolutwert berechnen") - - ;; fancy numeric - (exp (number -> number) - "Exponentialfunktion berechnen (e hoch Argument)") - (log (number -> number) - "natürlichen Logarithmus (Basis e) berechnen") - - ;; trigonometry - (sin (number -> number) - "Sinus berechnen (Argument in Radian)") - (cos (number -> number) - "Cosinus berechnen (Argument in Radian)") - (tan (number -> number) - "Tangens berechnen (Argument in Radian)") - (asin (number -> number) - "Arcussinus berechnen (in Radian)") - (acos (number -> number) - "Arcuscosinus berechnen (in Radian)") - (atan (number -> number) - "Arcustangens berechnen (in Radian)") - - (exact? (number -> boolean) - "feststellen, ob eine Zahl exakt ist") - - (integer? (any -> boolean) - "feststellen, ob ein Wert eine ganze Zahl ist") - (natural? (any -> boolean) - "feststellen, ob ein Wert eine natürliche Zahl (inkl. 0) ist") - - (zero? (number -> boolean) - "feststellen, ob eine Zahl Null ist") - (positive? (number -> boolean) - "feststellen, ob eine Zahl positiv ist") - (negative? (number -> boolean) - "feststellen, ob eine Zahl negativ ist") - (odd? (integer -> boolean) - "feststellen, ob eine Zahl ungerade ist") - (even? (integer -> boolean) - "feststellen, ob eine Zahl gerade ist") - - (lcm (integer integer ... -> natural) - "kleinstes gemeinsames Vielfaches berechnen") - - (gcd (integer integer ... -> natural) - "größten gemeinsamen Teiler berechnen") - - (rational? (any -> boolean) - "feststellen, ob eine Zahl rational ist") - - (numerator (rational -> integer) - "Zähler eines Bruchs berechnen") - - (denominator (rational -> natural) - "Nenner eines Bruchs berechnen") - - (inexact? (number -> boolean) - "feststellen, ob eine Zahl inexakt ist") - - (real? (any -> boolean) - "feststellen, ob ein Wert eine reelle Zahl ist") - - (floor (real -> integer) - "nächste ganze Zahl unterhalb einer rellen Zahlen berechnen") - - (ceiling (real -> integer) - "nächste ganze Zahl oberhalb einer rellen Zahlen berechnen") - - (round (real -> integer) - "relle Zahl auf eine ganze Zahl runden") - - (complex? (any -> boolean) - "feststellen, ob ein Wert eine komplexe Zahl ist") - - (make-polar (real real -> number) - "komplexe Zahl aus Abstand zum Ursprung und Winkel berechnen") - - (real-part (number -> real) - "reellen Anteil einer komplexen Zahl extrahieren") - - (imag-part (number -> real) - "imaginären Anteil einer komplexen Zahl extrahieren") - - (magnitude (number -> real) - "Abstand zum Ursprung einer komplexen Zahl berechnen") - - (angle (number -> real) - "Winkel einer komplexen Zahl berechnen") - - (exact->inexact (number -> number) - "eine Zahl durch eine inexakte Zahl annähern") - - (inexact->exact (number -> number) - "eine Zahl durch eine exakte Zahl annähern") - - ;; "Odds and ends" - - (number->string (number -> string) - "Zahl in Zeichenkette umwandeln") - - (string->number (string -> (mixed number false)) - "Zeichenkette in Zahl umwandeln, falls möglich") - - (random (natural -> natural) - "eine natürliche Zufallszahl berechnen, die kleiner als das Argument ist") - - (current-seconds (-> natural) - "aktuelle Zeit in Sekunden seit einem unspezifizierten Startzeitpunkt berechnen")) - - ("boolesche Werte" - (boolean? (any -> boolean) - "feststellen, ob ein Wert ein boolescher Wert ist") - - ((DMdA-not not) (boolean -> boolean) - "booleschen Wert negieren") - - (boolean=? (boolean boolean -> boolean) - "Booleans auf Gleichheit testen") - - (true? (any -> boolean) - "feststellen, ob ein Wert #t ist") - (false? (any -> boolean) - "feststellen, ob ein Wert #f ist")) - - ("Listen" - (empty list "die leere Liste") - (make-pair (%a (list-of %a) -> (list-of %a)) - "erzeuge ein Paar aus Element und Liste") - ((DMdA-cons cons) (%a (list-of %a) -> (list-of %a)) - "erzeuge ein Paar aus Element und Liste") - (pair? (any -> boolean) - "feststellen, ob ein Wert ein Paar ist") - (cons? (any -> boolean) - "feststellen, ob ein Wert ein Paar ist") - (empty? (any -> boolean) - "feststellen, ob ein Wert die leere Liste ist") - - (first ((list-of %a) -> %a) - "erstes Element eines Paars extrahieren") - (rest ((list-of %a) -> (list-of %a)) - "Rest eines Paars extrahieren") - - (list (%a ... -> (list-of %a)) - "Liste aus den Argumenten konstruieren") - - (length ((list-of %a) -> natural) - "Länge einer Liste berechnen") - - (fold (%b (%a %b -> %b) (list-of %a) -> %b) - "Liste einfalten.") - - ((DMdA-append append) ((list-of %a) ... -> (list-of %a)) - "mehrere Listen aneinanderhängen") - - (list-ref ((list-of %a) natural -> %a) - "das Listenelement an der gegebenen Position extrahieren") - - (reverse ((list-of %a) -> (list-of %a)) - "Liste in umgekehrte Reihenfolge bringen")) - - ("Computer" - (computer signature - "Signatur für Computer") - (make-computer (string rational rational -> computer) - "Computer aus Prozessorname, Arbeitsspeicher und Festplattenkapazität konstruieren") - (computer? (any -> boolean) - "feststellen, ob Wert ein Computer ist") - (computer-processor (computer -> string) - "Prozessorname aus Computer extrahieren") - (computer-ram (computer -> rational) - "Arbeitsspeicher aus Computer extrahieren") - (computer-hard-drive (computer -> rational) - "Festplattenkapazität aus Computer extrahieren")) - - ("Schokokekse" - (chocolate-cookie signature - "Signatur für Schokokekse") - (make-chocolate-cookie (number number -> chocolate-cookie) - "Schokokeks aus Schoko- und Keks-Anteil konstruieren") - (chocolate-cookie? (any -> boolean) - "feststellen, ob ein Wert ein Schokokeks ist") - (chocolate-cookie-chocolate (chocolate-cookie -> number) - "Schoko-Anteil eines Schokokekses extrahieren") - (chocolate-cookie-cookie (chocolate-cookie -> number) - "Keks-Anteil eines Schokokekses extrahieren")) - - ;; #### Zeichen sollten noch dazu, Vektoren wahrscheinlich auch - - ("Zeichenketten" - (string? (any -> boolean) - "feststellen, ob ein Wert eine Zeichenkette ist") - - (string=? (string string string ... -> boolean) - "Zeichenketten auf Gleichheit testen") - (string boolean) - "Zeichenketten lexikografisch auf kleiner-als testen") - (string>? (string string string ... -> boolean) - "Zeichenketten lexikografisch auf größer-als testen") - (string<=? (string string string ... -> boolean) - "Zeichenketten lexikografisch auf kleiner-gleich testen") - (string>=? (string string string ... -> boolean) - "Zeichenketten lexikografisch auf größer-gleich testen") - - (string-append (string string ... -> string) - "Hängt Zeichenketten zu einer Zeichenkette zusammen") - - (strings-list->string ((list string) -> string) - "Eine Liste von Zeichenketten in eine Zeichenkette umwandeln") - - (string->strings-list (string -> (list string)) - "Eine Zeichenkette in eine Liste von Zeichenketten mit einzelnen Zeichen umwandeln") - - (string-length (string -> natural) - "Liefert Länge einer Zeichenkette")) - - ("Symbole" - (symbol? (any -> boolean) - "feststellen, ob ein Wert ein Symbol ist") - (symbol=? (symbol symbol -> boolean) - "Sind zwei Symbole gleich?") - (symbol->string (symbol -> string) - "Symbol in Zeichenkette umwandeln") - (string->symbol (string -> symbol) - "Zeichenkette in Symbol umwandeln")) - - ("Verschiedenes" - (equal? (%a %b -> boolean) - "zwei Werte auf Gleichheit testen") - (eq? (%a %b -> boolean) - "zwei Werte auf Selbheit testen") - ((DMdA-write-string write-string) (string -> unspecific) - "Zeichenkette in REPL ausgeben") - (write-newline (-> unspecific) - "Zeilenumbruch ausgeben") - (violation (string -> unspecific) - "Programmm mit Fehlermeldung abbrechen") - - (map ((%a -> %b) (list %a) -> (list %b)) - "Prozedur auf alle Elemente einer Liste anwenden, Liste der Resultate berechnen") - (for-each ((%a -> %b) (list %a) -> unspecific) - "Prozedur von vorn nach hinten auf alle Elemente einer Liste anwenden") - (apply (procedure (list %a) -> %b) - "Prozedur auf Liste ihrer Argumente anwenden") - (read (-> any) - "Externe Repräsentation eines Werts in der REPL einlesen und den zugehörigen Wert liefern"))) - -(define real-make-pair - (let () - (define make-pair - (procedure-rename - (lambda (f r) - (when (and (not (null? r)) - (not (pair? r))) - (raise - (make-exn:fail:contract - (string->immutable-string - (format "Zweites Argument zu make-pair ist keine Liste, sondern ~e" r)) - (current-continuation-marks)))) - (cons f r)) - 'make-pair)) - make-pair)) - -(define-syntax make-pair - (let () - ;; make it work with match - (define-struct pair-info () - #:super struct:struct-info - #:property - prop:procedure - (lambda (_ stx) - (syntax-case stx () - ((self . args) (syntax/loc stx (real-make-pair . args))) - (else (syntax/loc stx real-make-pair))))) - (make-pair-info (lambda () - (list #f - #'real-make-pair - #'pair? - (list #'cdr #'car) - '(#f #f) - #f))))) - -(define (first l) - (when (not (pair? l)) - (raise - (make-exn:fail:contract - (string->immutable-string - (format "Argument zu first kein Paar, sondern ~e" l)) - (current-continuation-marks)))) - (car l)) - -(define (rest l) - (when (not (pair? l)) - (raise - (make-exn:fail:contract - (string->immutable-string - (format "Argument zu rest kein Paar, sondern ~e" l)) - (current-continuation-marks)))) - (cdr l)) - -(define empty '()) - -(define (empty? obj) - (null? obj)) - -(define (cons? obj) - (pair? obj)) - -(define-teach DMdA cons - (lambda (f r) - (make-pair f r))) - -(define-teach DMdA append - (lambda args - (let loop ((args args) - (seen-rev '())) - (when (not (null? args)) - (let ((arg (car args))) - (when (and (not (null? arg)) - (not (pair? arg))) - (raise - (make-exn:fail:contract - (string->immutable-string - (format "Argument zu append keine Liste, sondern ~e; restliche Argumente:~a" - arg - (apply string-append - (map (lambda (arg) - (format " ~e" arg)) - (append (reverse seen-rev) - (list '<...>) - (cdr args)))))) - (current-continuation-marks)))) - (loop (cdr args) - (cons arg seen-rev))))) - - (apply append args))) - -(define fold - (lambda (unit combine lis) - (cond - ((empty? lis) unit) - ((pair? lis) - (combine (first lis) - (fold unit combine (rest lis)))) - (else - (raise - (make-exn:fail:contract - (string->immutable-string - (format "Argument zu fold keine Liste, sondern ~e; andere Argumente: ~e ~e" - lis - unit combine)) - (current-continuation-marks))))))) - -;; This is copied from collects/lang/private/beginner-funs.rkt -;; Test-suite support (require is really an effect -;; to make sure that it's loaded) -(require "test-suite.rkt") - -(define-for-syntax (binding-in-this-module? b) - (and (list? b) - (module-path-index? (car b)) - (let-values (((path base) (module-path-index-split (car b)))) - (and (not path) (not base))))) - -(define-for-syntax (transform-DMdA-define stx mutable?) - (unless (memq (syntax-local-context) '(module top-level)) - (raise-syntax-error - #f "Define muss ganz außen stehen" stx)) - (syntax-case stx () - ((DMdA-define) - (raise-syntax-error - #f "Definition ohne Operanden" stx)) - ((DMdA-define v) - (raise-syntax-error - #f "Define erwartet zwei Operanden, nicht einen" stx)) - ((DMdA-define var expr) - (begin - (check-for-id! - (syntax var) - "Der erste Operand der Definition ist kein Bezeichner") - - (let ((binding (identifier-binding (syntax var)))) - (when binding - (if (binding-in-this-module? binding) - (raise-syntax-error - #f - "Zweite Definition für denselben Namen" - stx) - (raise-syntax-error - #f - "Dieser Name gehört einer eingebauten Prozedur und kann nicht erneut definiert werden" (syntax var))))) - (if mutable? - (with-syntax - ((dummy-def (stepper-syntax-property - (syntax (define dummy (lambda () (set! var 'dummy)))) - 'stepper-skip-completely - #t))) - (syntax/loc stx - (begin - dummy-def - (define var expr)))) - (syntax/loc stx (define var expr))))) - ((DMdA-define v e1 e2 e3 ...) - (raise-syntax-error - #f "Definition mit mehr als zwei Operanden" stx)))) - -(define-syntax (DMdA-define stx) - (transform-DMdA-define stx #f)) - -(define-syntax (DMdA-advanced-define stx) - (transform-DMdA-define stx #t)) - -(define-syntax (DMdA-let stx) - (syntax-case stx () - ((DMdA-let () body) - (syntax/loc stx body)) - ((DMdA-let ((var expr) ...) body) - (begin - (check-for-id-list! - (syntax->list (syntax (var ...))) - "Kein Bezeichner in Let-Bindung") - (syntax/loc stx ((lambda (var ...) body) expr ...)))) - ((DMdA-let ((var expr) ...) body1 body2 ...) - (raise-syntax-error - #f "Let-Ausdruck hat mehr als einen Ausdruck als Rumpf" stx)) - ((DMdA-let expr ...) - (raise-syntax-error - #f "Let-Ausdruck erwartet eine Liste von Bindungen (Paare aus Name und Ausdruck) und einen Rumpf" stx)))) - -(define-syntax (DMdA-let* stx) - (syntax-case stx () - ((DMdA-let* () body) - (syntax/loc stx body)) - ((DMdA-let* ((var1 expr1) (var2 expr2) ...) body) - (begin - (check-for-id! - (syntax var1) - "Kein Bezeichner in Let*-Bindung") - (syntax/loc stx ((lambda (var1) - (DMdA-let* ((var2 expr2) ...) body)) - expr1)))) - ((DMdA-let* ((var expr) ...) body1 body2 ...) - (raise-syntax-error - #f "Let*-Ausdruck hat mehr als einen Ausdruck als Rumpf" stx)) - ((DMdA-let* expr ...) - (raise-syntax-error - #f "Let*-Ausdruck erwartet eine Liste von Bindungen (Paare aus Name und Ausdruck) und einen Rumpf" stx)))) - -(define-syntax (DMdA-letrec stx) - (syntax-case stx () - ((DMdA-letrec ((var expr) ...) body) - (begin - (check-for-id-list! - (syntax->list (syntax (var ...))) - "Kein Bezeichner in letrec-Bindung") - (syntax/loc stx (letrec ((var expr) ...) body)))) - ((DMdA-letrec ((var expr) ...) body1 body2 ...) - (raise-syntax-error - #f "Letrec hat mehr als einen Ausdruck als Rumpf" stx)))) - -(define-syntax (DMdA-lambda stx) - (syntax-case stx () - ((DMdA-lambda (var ...) body) - (begin - (check-for-id-list! - (syntax->list (syntax (var ...))) - "Kein Bezeichner als Parameter der Lambda-Abstraktion") - (syntax/loc stx (lambda (var ...) body)))) - ((DMdA-lambda (var ...) body1 body2 ...) - (raise-syntax-error - #f "Lambda-Abstraktion hat mehr als einen Ausdruck als Rumpf" stx)) - ((DMdA-lambda var body ...) - (identifier? (syntax var)) - (raise-syntax-error - #f "Um die Parameter einer Lambda-Abstraktion gehören Klammern" (syntax var))) - ((DMdA-lambda var ...) - (raise-syntax-error - #f "Fehlerhafte Lambda-Abstraktion" stx)))) - -(define-syntax (DMdA-advanced-lambda stx) - (syntax-case stx () - ((DMdA-lambda (var ...) body) - (begin - (check-for-id-list! - (syntax->list (syntax (var ...))) - "Kein Bezeichner als Parameter der Lambda-Abstraktion") - (syntax/loc stx (lambda (var ...) body)))) - ((DMdA-lambda (var ... . rest) body) - (begin - (check-for-id-list! - (syntax->list (syntax (var ...))) - "Kein Bezeichner als Parameter der Lambda-Abstraktion") - (check-for-id! - (syntax rest) - "Kein Bezeichner als Restlisten-Parameter der Lambda-Abstraktion") - (syntax/loc stx (lambda (var ... . rest) body)))) - ((DMdA-lambda (var ...) body1 body2 ...) - (raise-syntax-error - #f "Lambda-Abstraktion hat mehr als einen Ausdruck als Rumpf" stx)) - ((DMdA-lambda var ...) - (raise-syntax-error - #f "Fehlerhafte Lambda-Abstraktion" stx)))) - -(define-syntax (DMdA-begin stx) - (syntax-case stx () - ((DMdA-begin) - (raise-syntax-error - #f "Begin-Ausdruck braucht mindestens einen Operanden" stx)) - ((DMdA-begin expr1 expr2 ...) - (syntax/loc stx (begin expr1 expr2 ...))))) - -(define-for-syntax (local-expand-for-error stx ctx stops) - ;; This function should only be called in an 'expression - ;; context. In case we mess up, avoid bogus error messages. - (when (memq (syntax-local-context) '(expression)) - (local-expand stx ctx stops))) - -(define-for-syntax (ensure-expression stx k) - (if (memq (syntax-local-context) '(expression)) - (k) - (stepper-syntax-property #`(begin0 #,stx) 'stepper-skipto skipto/second))) - -;; A consistent pattern for stepper-skipto: -(define-for-syntax (stepper-ignore-checker stx) - (stepper-syntax-property stx 'stepper-skipto '(syntax-e cdr syntax-e cdr car))) - -;; Raise a syntax error: -(define-for-syntax (teach-syntax-error form stx detail msg . args) - (let ([form (if (eq? form '|function call|) ; #### - form - #f)] ; extract name from stx - [msg (apply format msg args)]) - (if detail - (raise-syntax-error form msg stx detail) - (raise-syntax-error form msg stx)))) - -;; The syntax error when a form's name doesn't follow a "(" -(define-for-syntax (bad-use-error name stx) - (teach-syntax-error - name - stx - #f - "`~a' wurde an einer Stelle gefunden, die keiner offenen Klammer folgt" - name)) - -;; Use for messages "expected ..., found " -(define-for-syntax (something-else v) - (let ([v (syntax-e v)]) - (cond - [(number? v) "eine Zahl"] - [(string? v) "eine Zeichenkette"] - [else "etwas anderes"]))) -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; cond -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-syntax (DMdA-cond stx) - (ensure-expression - stx - (lambda () - (syntax-case stx () - [(_) - (teach-syntax-error - 'cond - stx - #f - "Frage und eine Antwort nach `cond' erwartet, aber da ist nichts")] - [(_ clause ...) - (let* ([clauses (syntax->list (syntax (clause ...)))] - [check-preceding-exprs - (lambda (stop-before) - (let/ec k - (for-each (lambda (clause) - (if (eq? clause stop-before) - (k #t) - (syntax-case clause () - [(question answer) - (begin - (unless (and (identifier? (syntax question)) - (free-identifier=? (syntax question) #'DMdA-else)) - (local-expand-for-error (syntax question) 'expression null)) - (local-expand-for-error (syntax answer) 'expression null))]))) - clauses)))]) - (let ([checked-clauses - (map - (lambda (clause) - (syntax-case clause (DMdA-else) - [(DMdA-else answer) - (let ([lpos (memq clause clauses)]) - (when (not (null? (cdr lpos))) - (teach-syntax-error - 'cond - stx - clause - "`else'-Test gefunden, der nicht am Ende des `cond'-Ausdrucks steht")) - (with-syntax ([new-test (stepper-syntax-property (syntax #t) 'stepper-else #t)]) - (syntax/loc clause (new-test answer))))] - [(question answer) - (with-syntax ([verified (stepper-ignore-checker (syntax (verify-boolean question 'cond)))]) - (syntax/loc clause (verified answer)))] - [() - (check-preceding-exprs clause) - (teach-syntax-error - 'cond - stx - clause - "Test und Ausdruck in Zweig erwartet, aber Zweig leer")] - [(question?) - (check-preceding-exprs clause) - (teach-syntax-error - 'cond - stx - clause - "Zweig mit Test und Ausdruck erwartet, aber Zweig enthält nur eine Form")] - [(question? answer? ...) - (check-preceding-exprs clause) - (let ([parts (syntax->list clause)]) - ;; to ensure the illusion of left-to-right checking, make sure - ;; the question and first answer (if any) are ok: - (unless (and (identifier? (car parts)) - (free-identifier=? (car parts) #'DMdA-else)) - (local-expand-for-error (car parts) 'expression null)) - (unless (null? (cdr parts)) - (local-expand-for-error (cadr parts) 'expression null)) - ;; question and answer (if any) are ok, raise a count-based exception: - (teach-syntax-error - 'cond - stx - clause - "Zweig mit Test und Ausdruck erwartet, aber Zweig enthält ~a Formen" - (length parts)))] - [_else - (teach-syntax-error - 'cond - stx - clause - "Zweig mit Test und Ausdruck erwartet, aber ~a gefunden" - (something-else clause))])) - clauses)]) - ;; Add `else' clause for error (always): - (let ([clauses (append checked-clauses - (list - (with-syntax ([error-call (syntax/loc stx (error 'cond "alle Tests ergaben #f"))]) - (syntax [else error-call]))))]) - (with-syntax ([clauses clauses]) - (syntax/loc stx (cond . clauses))))))] - [_else (bad-use-error 'cond stx)])))) - -(define-syntax DMdA-else - (make-set!-transformer - (lambda (stx) - (define (bad expr) - (teach-syntax-error - 'else - expr - #f - "hier nicht erlaubt, weil kein Test in `cond'-Zweig")) - (syntax-case stx (set! x) - [(set! e expr) (bad #'e)] - [(e . expr) (bad #'e)] - [e (bad stx)])))) - -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; if -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-syntax (DMdA-if stx) - (ensure-expression - stx - (lambda () - (syntax-case stx () - [(_ test then else) - (with-syntax ([new-test (stepper-ignore-checker (syntax (verify-boolean test 'if)))]) - (syntax/loc stx - (if new-test - then - else)))] - [(_ . rest) - (let ([n (length (syntax->list (syntax rest)))]) - (teach-syntax-error - 'if - stx - #f - "Test und zwei Ausdrücke erwartet, aber ~a Form~a gefunden" - (if (zero? n) "keine" n) - (if (= n 1) "" "en")))] - [_else (bad-use-error 'if stx)])))) - -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; or, and -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-syntaxes (DMdA-or DMdA-and) - (let ([mk - (lambda (where) - (let ([stepper-tag (case where - [(or) 'comes-from-or] - [(and) 'comes-from-and])]) - (with-syntax ([swhere where]) - (lambda (stx) - (ensure-expression - stx - (lambda () - (syntax-case stx () - [(_ . clauses) - (let ([n (length (syntax->list (syntax clauses)))]) - (let loop ([clauses-consumed 0] - [remaining (syntax->list #`clauses)]) - (if (null? remaining) - (case where - [(or) #`#f] - [(and) #`#t]) - (stepper-syntax-property - (stepper-syntax-property - (quasisyntax/loc - stx - (if #,(stepper-ignore-checker (quasisyntax/loc stx (verify-boolean #,(car remaining) 'swhere))) - #,@(case where - [(or) #`(#t - #,(loop (+ clauses-consumed 1) (cdr remaining)))] - [(and) #`(#,(loop (+ clauses-consumed 1) (cdr remaining)) - #f)]))) - 'stepper-hint - stepper-tag) - 'stepper-and/or-clauses-consumed - clauses-consumed))))] - [_else (bad-use-error where stx)])))))))]) - (values (mk 'or) (mk 'and)))) - -;; verify-boolean is inserted to check for boolean results: -(define (verify-boolean b where) - (if (or (eq? b #t) (eq? b #f)) - b - (raise - (make-exn:fail:contract - (string->immutable-string - (format "~a: Testresultat ist nicht boolesch: ~e" where b)) - (current-continuation-marks))))) - -(define-teach DMdA not - (lambda (b) - (verify-boolean b 'not) - (not b))) - -(define (boolean=? a b) - (verify-boolean a 'boolean=?) - (verify-boolean b 'boolean=?) - (eq? a b)) - -(define (verify-symbol b where) - (if (symbol? b) - b - (raise - (make-exn:fail:contract - (string->immutable-string - (format "~a: Wert ist kein Symbol: ~e" where b)) - (current-continuation-marks))))) - -(define (symbol=? a b) - (verify-symbol a 'symbol=?) - (verify-symbol b 'symbol=?) - (eq? a b)) - -(define-syntax (DMdA-app stx) - (syntax-case stx () - ((_) - (raise-syntax-error - #f "Zusammengesetzte Form ohne Operator" (syntax/loc stx ()))) - ((_ datum1 datum2 ...) - (let ((scm-datum (syntax->datum (syntax datum1)))) - (or (number? scm-datum) - (boolean? scm-datum) - (string? scm-datum) - (char? scm-datum))) - (raise-syntax-error #f "Operator darf kein Literal sein" (syntax datum1))) - ((_ datum1 datum2 ...) - (syntax/loc stx (#%app datum1 datum2 ...))))) - -(define-syntax (DMdA-top stx) - (syntax-case stx () - ((_ . id) - ;; If we're in a module, we'll need to check that the name - ;; is bound.... - (if (and (not (identifier-binding #'id)) - (syntax-source-module #'id)) - ;; ... but it might be defined later in the module, so - ;; delay the check. - (stepper-ignore-checker - (syntax/loc stx (#%app values (DMdA-top-continue id)))) - (syntax/loc stx (#%top . id)))))) - -(define-syntax (DMdA-top-continue stx) - (syntax-case stx () - [(_ id) - ;; If there's still no binding, it's an "unknown name" error. - (if (not (identifier-binding #'id)) - (raise-syntax-error #f "Ungebundene Variable" (syntax/loc stx id)) - ;; Don't use #%top here; id might have become bound to something - ;; that isn't a value. - #'id)])) - -(define-teach DMdA write-string - (lambda (s) - (when (not (string? s)) - (error "Argument von write-string ist keine Zeichenkette")) - (display s))) - -(define (write-newline) - (newline)) - -(define-record-procedures chocolate-cookie - make-chocolate-cookie chocolate-cookie? - (chocolate-cookie-chocolate chocolate-cookie-cookie)) - -(define-record-procedures computer - make-computer computer? - (computer-processor - computer-ram - computer-hard-drive)) - -(define (violation text) - (error text)) - -(define (string->strings-list s) - (map (lambda (c) (make-string 1 c)) (string->list s))) - -(define (strings-list->string l) - (if (null? l) - "" - (string-append (car l) (strings-list->string (cdr l))))) - -(define integer (signature/arbitrary arbitrary-integer (predicate integer?))) -(define number (signature/arbitrary arbitrary-real (predicate number?))) -(define rational (signature/arbitrary arbitrary-rational (predicate rational?))) -(define real (signature/arbitrary arbitrary-real (predicate real?))) - -(define (natural? x) - (and (integer? x) - (not (negative? x)))) - -(define natural (signature/arbitrary arbitrary-natural (predicate natural?))) - -(define boolean (signature/arbitrary arbitrary-boolean (predicate boolean?))) - -(define (true? x) - (eq? x #t)) - -(define (false? x) - (eq? x #f)) - -(define true (signature (one-of #t))) -(define false (signature (one-of #f))) - -(define string (signature/arbitrary arbitrary-printable-ascii-string (predicate string?))) -(define symbol (signature/arbitrary arbitrary-symbol (predicate symbol?))) -(define empty-list (signature (one-of empty))) - -(define unspecific (signature unspecific %unspecific)) -(define any (signature any %any)) - -;; aus collects/lang/private/teach.rkt - -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; dots (.. and ... and .... and ..... and ......) -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Syntax Identifier -> Expression -;; Produces an expression which raises an error reporting unfinished code. -(define-for-syntax (dots-error stx name) - (quasisyntax/loc stx - (error (quote (unsyntax name)) - "Fertiger Ausdruck erwartet, aber da sind noch Ellipsen"))) - -;; Expression -> Expression -;; Transforms unfinished code (... and the like) to code -;; raising an appropriate error. -(define-syntax DMdA-dots - (make-set!-transformer - (lambda (stx) - (syntax-case stx (set!) - [(set! form expr) (dots-error stx (syntax form))] - [(form . rest) (dots-error stx (syntax form))] - [form (dots-error stx stx)])))) - -(define-syntaxes (DMdA-set! DMdA-set!-continue) - (let ((proc - (lambda (continuing?) - (lambda (stx) - (ensure-expression - stx - (lambda () - (syntax-case stx () - ((_ id expr) - (identifier? (syntax id)) - (begin - ;; Check that id isn't syntax, and not lexical. - ((with-handlers ((exn:fail? (lambda (exn) void))) - ;; First try syntax: - ;; If it's a transformer binding, then it can take care of itself... - (if (set!-transformer? (syntax-local-value (syntax id))) - void ;; no lex check wanted - (lambda () - (raise-syntax-error - #f - "Nach set! wird eine gebundene Variable erwartet, aber da ist ein Schlüsselwort." - stx))))) - ;; If we're in a module, we'd like to check here whether - ;; the identier is bound, but we need to delay that check - ;; in case the id is defined later in the module. So only - ;; do this in continuing mode: - (when continuing? - (when (and (not (identifier-binding #'id)) - (syntax-source-module #'id)) - (raise-syntax-error #f "Ungebundene Variable" #'id))) - (if continuing? - (syntax/loc stx (set! id expr)) - (stepper-ignore-checker (syntax/loc stx (#%app values (DMdA-set!-continue id expr))))))) - ((_ id expr) - (raise-syntax-error - #f - "Nach set! wird eine Variable aber da ist etwas anderes." - #'id)) - ((_ id) - (raise-syntax-error - #f - "Nach set! wird eine Variable und ein Ausdruck erwartet - der Ausdruck fehlt." - stx)) - ((_) - (raise-syntax-error - #f - "Nach set! wird eine Variable und ein Ausdruck erwartet, aber da ist nichts." - stx)) - (_else - (raise-syntax-error - #f - "Inkorrekter set!-Ausdruck." - stx))))))))) - (values (proc #f) - (proc #t)))) - -; QuickCheck - -(define-syntax (for-all stx) - (syntax-case stx () - ((_ (?clause ...) ?body) - (with-syntax ((((?id ?arb) ...) - (map (lambda (pr) - (syntax-case pr () - ((?id ?signature) - (identifier? #'?id) - (with-syntax ((?error-call - (syntax/loc #'?signature (error "Signatur hat keinen Generator")))) - #'(?id - (or (signature-arbitrary (signature ?signature)) - ?error-call)))) - (_ - (raise-syntax-error #f "inkorrekte `for-all'-Klausel - sollte die Form (id contr) haben" - pr)))) - (syntax->list #'(?clause ...))))) - - (stepper-syntax-property #'(quickcheck:property - ((?id ?arb) ...) ?body) - 'stepper-skip-completely - #t))) - ((_ ?something ?body) - (raise-syntax-error #f "keine Klauseln der Form (id contr)" - stx)) - ((_ ?thing1 ?thing2 ?thing3 ?things ...) - (raise-syntax-error #f "zuviele Operanden" - stx)))) - -(define-syntax (check-property stx) - (unless (memq (syntax-local-context) '(module top-level)) - (raise-syntax-error - #f "`check-property' muss ganz außen stehen" stx)) - (syntax-case stx () - ((_ ?prop) - (stepper-syntax-property - (check-expect-maker stx #'check-property-error #'?prop '() - 'comes-from-check-property) - 'stepper-replace - #'#t)) - (_ (raise-syntax-error #f "`check-property' erwartet einen einzelnen Operanden" - stx)))) - -(define (check-property-error test src-info test-info) - (let ((info (send test-info get-info))) - (send info add-check) - (with-handlers ((exn:fail? - (lambda (e) - (send info property-error e src-info) - (raise e)))) - (call-with-values - (lambda () - (with-handlers - ((exn:assertion-violation? - (lambda (e) - ;; minor kludge to produce comprehensible error message - (if (eq? (exn:assertion-violation-who e) 'coerce->result-generator) - (raise (make-exn:fail (string-append "Wert muß Eigenschaft oder boolesch sein: " - ((error-value->string-handler) - (car (exn:assertion-violation-irritants e)) - 100)) - (exn-continuation-marks e))) - (raise e))))) - (quickcheck-results (test)))) - (lambda (ntest stamps result) - (if (check-result? result) - (begin - (send info property-failed result src-info) - #f) - #t)))))) - -(define (expect v1 v2) - (quickcheck:property () (teach-equal? v1 v2))) - -(define (ensure-real who n val) - (unless (real? val) - (raise - (make-exn:fail:contract - (string->immutable-string - (format "~a Argument ~e zu `~a' keine reelle Zahl." n val who)) - (current-continuation-marks))))) - -(define (expect-within v1 v2 epsilon) - (ensure-real 'expect-within "Drittes" epsilon) - (quickcheck:property () (beginner-equal~? v1 v2 epsilon))) - -(define (expect-range val min max) - (ensure-real 'expect-range "Erstes" val) - (ensure-real 'expect-range "Zweites" min) - (ensure-real 'expect-range "Drittes" max) - (quickcheck:property () - (and (<= min val) - (<= val max)))) - -(define (expect-member-of val . candidates) - (quickcheck:property () - (ormap (lambda (cand) - (teach-equal? val cand)) - candidates))) - -(define property (signature (predicate (lambda (x) - (or (boolean? x) - (property? x)))))) - - -(define-syntax (match stx) - (syntax-parse stx - ((_ ?case:expr (?pattern0 ?body0:expr) (?pattern ?body:expr) ...) - (let () - (define (pattern-variables pat) - (syntax-case pat (empty make-pair list quote) - (empty '()) - (?var (identifier? #'?var) - (if (eq? (syntax->datum #'?var) '_) - '() - (list #'?var))) - (?lit (let ((d (syntax->datum #'?lit))) - (or (string? d) (number? d) (boolean? d))) - '()) - ('?lit '()) - ((make-pair ?pat1 ?pat2) - (append (pattern-variables #'?pat1) (pattern-variables #'?pat2))) - ((list) '()) - ((list ?pat0 ?pat ...) - (apply append (map pattern-variables (syntax->list #'(?pat0 ?pat ...))))) - ((?const ?pat ...) - (apply append (map pattern-variables (syntax->list #'(?pat ...))))))) - (define (check pat) - (let loop ((vars (pattern-variables pat))) - (when (pair? vars) - (let ((var (car vars))) - (when (memf (lambda (other-var) - (free-identifier=? var other-var)) - (cdr vars)) - (raise-syntax-error #f "Variable in match-Zweig kommt doppelt vor" - var)) - (loop (cdr vars)))))) - (for-each check (syntax->list #'(?pattern0 ?pattern ...))) - #'(let* ((val ?case) - (nomatch (lambda () (match val (?pattern ?body) ...)))) - (match-helper val ?pattern0 ?body0 (nomatch))))) - ((_ ?case:expr) - (syntax/loc stx (error 'match "keiner der Zweige passte"))))) - - -(define (list-length=? lis n) - (cond - ((zero? n) (null? lis)) - ((null? lis) #f) - (else - (list-length=? (cdr lis) (- n 1))))) - -(define-syntax (match-helper stx) - (syntax-case stx () - ((_ ?id ?pattern0 ?body0 ?nomatch) - (syntax-case #'?pattern0 (empty make-pair list quote) - (empty - #'(if (null? ?id) - ?body0 - ?nomatch)) - (?var (identifier? #'?var) - (if (eq? (syntax->datum #'?var) '_) ; _ is magic - #'?body0 - #'(let ((?var ?id)) - ?body0))) - (?lit (let ((d (syntax->datum #'?lit))) - (or (string? d) (number? d) (boolean? d))) - #'(if (equal? ?id ?lit) - ?body0 - ?nomatch)) - ('?lit - #'(if (equal? ?id '?lit) - ?body0 - ?nomatch)) - ((make-pair ?pat1 ?pat2) - #'(if (pair? ?id) - (let ((f (first ?id)) - (r (rest ?id))) - (match-helper f ?pat1 - (match-helper r ?pat2 ?body0 ?nomatch) - ?nomatch)) - ?nomatch)) - ((list) - #'(if (null? ?id) - ?body0 - ?nomatch)) - ((list ?pat0 ?pat ...) - (let* ((pats (syntax->list #'(?pat0 ?pat ...))) - (cars (generate-temporaries pats)) - (cdrs (generate-temporaries pats))) - #`(if (and (pair? ?id) - (list-length=? ?id #,(length pats))) - #,(let recur ((ccdr #'?id) - (pats pats) - (cars cars) (cdrs cdrs)) - (if (null? pats) - #'?body0 - #`(let ((#,(car cars) (car #,ccdr)) - (#,(car cdrs) (cdr #,ccdr))) - (match-helper #,(car cars) #,(car pats) - #,(recur (car cdrs) (cdr pats) (cdr cars) (cdr cdrs)) - ?nomatch)))) - ?nomatch))) - ((?const ?pat ...) - (identifier? #'?const) - (let* ((fail (lambda () - (raise-syntax-error #f "Operator in match muss ein Record-Konstruktor sein" - #'?const))) - (v (syntax-local-value #'?const fail))) - (unless (struct-info? v) - (fail)) - - (apply - (lambda (_ _cons pred rev-selectors _mutators ?) - (let* ((pats (syntax->list #'(?pat ...))) - (selectors (reverse rev-selectors)) - (field-ids (generate-temporaries pats))) - (unless (= (length rev-selectors) (length pats)) - (raise-syntax-error #f "Die Anzahl der Felder im match stimmt nicht" stx)) - #`(if (#,pred ?id) - #,(let recur ((pats pats) - (selectors selectors) - (field-ids field-ids)) - (if (null? pats) - #'?body0 - #`(let ((#,(car field-ids) (#,(car selectors) ?id))) - (match-helper #,(car field-ids) #,(car pats) - #,(recur (cdr pats) (cdr selectors) (cdr field-ids)) - ?nomatch)))) - ?nomatch))) - (extract-struct-info v)))))))) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA-vanilla-reader.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA-vanilla-reader.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA-vanilla-reader.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA-vanilla-reader.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1,6 +1,6 @@ (module DMdA-vanilla-reader mzscheme - (require "DMdA-reader.rkt") + (require deinprogramm/DMdA/private/DMdA-reader) (provide (rename -read-syntax read-syntax) (rename -read read)) - (define -read-syntax (make-read-syntax '(lib "DMdA-vanilla.ss" "deinprogramm"))) - (define -read (make-read '(lib "DMdA-vanilla.ss" "deinprogramm")))) + (define -read-syntax (make-read-syntax '(lib "DMdA-vanilla.rkt" "deinprogramm"))) + (define -read (make-read '(lib "DMdA-vanilla.rkt" "deinprogramm")))) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA-vanilla.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA-vanilla.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/DMdA-vanilla.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/DMdA-vanilla.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -13,7 +13,7 @@ number real rational integer natural boolean true false string empty-list any property) (provide-and-document procedures - (all-from-except vanilla: deinprogramm/DMdA procedures + (all-from-except vanilla: deinprogramm/DMdA/private/primitives procedures quote eq? equal? set! define-record-procedures-2 diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/image.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/image.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/image.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/image.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,870 +0,0 @@ -#lang scheme/base - -#| - -The test suite for this code is in -collects/tests/deinprogramm/image.rkt - -|# - -(require (except-in mred - make-color) - mzlib/class - mrlib/cache-image-snip - mzlib/math - lang/prim - lang/posn - lang/private/imageeq - htdp/error - deinprogramm/signature/signature-syntax - (only-in deinprogramm/DMdA integer natural)) - -(provide ; #### -primitives doesn't work for us - image? - image-width - image-height - - empty-image - - overlay - above - beside - - clip - pad - - rectangle - circle - ellipse - triangle - line - text - - image-inside? - find-image - - image->color-list - color-list->image - - image->alpha-color-list - alpha-color-list->image - - image-color? - make-color - color-red - color-green - color-blue - color? - make-alpha-color - alpha-color-alpha - alpha-color-red - alpha-color-green - alpha-color-blue - alpha-color? - - octet rgb-color alpha-rgb-color mode image image-color - h-place v-place h-mode v-mode) - -;; ---------------------------------------- - -(define (color-list? l) - (and (list? l) (andmap image-color? l))) -(define (alpha-color-list? l) - (and (list? l) (andmap alpha-color? l))) - -(define-struct color (red green blue) #:inspector (make-inspector)) -(define-struct alpha-color (alpha red green blue) #:inspector (make-inspector)) - -;; ---------------------------------------- - -(define (check name p? v desc arg-posn) (check-arg name (p? v) desc arg-posn v)) - -(define (check-coordinate name val arg-posn) (check name finite-real? val "real" arg-posn)) -(define (check-integer-coordinate name val arg-posn) (check name nii? val "integer" arg-posn)) -(define (check-size name val arg-posn) (check name pos-real? val "positive real" arg-posn)) -(define (check-posi-size name val arg-posn) (check name pos-integer? val "positive integer" arg-posn)) -(define (check-size/0 name val arg-posn) (check name nn-real? val "non-negative real" arg-posn)) -(define (check-h-place name val arg-posn) - (check name h-place? val - "non-negative exact integer or horizontal alignment position" - arg-posn)) -(define (check-v-place name val arg-posn) - (check name v-place? val - "non-negative exact integer or vertical alignment position" - arg-posn)) -(define (check-image name val arg-posn) (check name image? val "image" arg-posn)) -(define (check-image-color name val arg-posn) - (let ([simple-check (lambda (x) (or (string? x) (symbol? x) (color? x)))]) - (check name simple-check val "image-color" arg-posn) - (unless (image-color? val) - (error name "~e is not a valid color name" val)))) -(define (check-mode name val arg-posn) (check name mode? val mode-str arg-posn)) - -(define (pos-real? i) (and (real? i) (positive? i))) -(define (pos-integer? i) (and (integer? i) (positive? i))) -(define (nn-real? i) (and (real? i) (or (zero? i) (positive? i)))) -(define (nii? x) (and (integer? x) (not (= x +inf.0)) (not (= x -inf.0)))) - -(define (finite-real? x) (and (real? x) (not (= x +inf.0)) (not (= x -inf.0)))) - -(define (check-sizes who w h) - (unless (and (< 0 w 10000) (< 0 h 10000)) - (error (format "cannot make ~a x ~a image" w h)))) - -(define (mode? x) - (member x '(solid "solid" outline "outline"))) - -(define mode-str "'solid \"solid\" 'outline or \"outline\"") - -(define (mode->brush-symbol m) - (cond - [(member m '(solid "solid")) - 'solid] - [(member m '(outline "outline")) - 'transparent])) - -(define (mode->pen-symbol m) - (cond - [(member m '(solid "solid")) 'transparent] - [(member m '(outline "outline")) 'solid])) - -(define (h-place? x) - (or (nn-real? x) - (h-mode? x))) - -(define (v-place? x) - (or (nn-real? x) - (v-mode? x))) - -(define (h-mode? x) - (member x '(left "left" right "right" "center"))) - -(define (v-mode? x) - (member x '(top "top" bottom "bottom" center "center"))) - -(define (make-color% c) - (cond - [(string? c) (send the-color-database find-color c)] - [(symbol? c) (send the-color-database find-color (symbol->string c))] - [(color? c) (make-object color% - (color-red c) - (color-green c) - (color-blue c))] - [else #f])) - -(define (image-color? c) - (cond - [(color? c) #t] - [(string? c) (and (send the-color-database find-color c) #t)] - [(symbol? c) (and (send the-color-database find-color (symbol->string c)) #t)] - [else #f])) - -(define (image-width a) - (check-image 'image-width a "first") - (let-values ([(w h) (snip-size a)]) - (inexact->exact (ceiling w)))) - -(define (image-height a) - (check-image 'image-height a "first") - (let-values ([(w h) (snip-size a)]) - (inexact->exact (ceiling h)))) - -(define (overlay a b h-place v-place) - (overlay-helper 'overlay a b h-place v-place)) - -(define (overlay-helper name a b h-place v-place) - (check-image name a "first") - (check-image name b "second") - (check-h-place name h-place "third") - (check-v-place name v-place "fourth") - (let ((dx (h-place->delta-x h-place a b)) - (dy (v-place->delta-y v-place a b))) - (real-overlay name - a - (inexact->exact (floor dx)) - (inexact->exact (floor dy)) - b))) - -(define (h-place->delta-x h-place a b) - (cond - ((real? h-place) (inexact->exact (floor h-place))) - ((member h-place '(left "left")) 0) - ((member h-place '(right "right")) - (- (image-width a) (image-width b))) - ((member h-place '(center "center")) - (- (quotient (image-width a) 2) - (quotient (image-width b) 2))))) - -(define (v-place->delta-y v-place a b) - (cond - ((real? v-place) (inexact->exact (floor v-place))) - ((member v-place '(top "top")) 0) - ((member v-place '(bottom "bottom")) - (- (image-height a) (image-height b))) - ((member v-place '(center "center")) - (- (quotient (image-height a) 2) - (quotient (image-height b) 2))))) - -(define (above a b h-mode) - (overlay-helper 'above a b h-mode (image-height a))) - -(define (beside a b v-mode) - (overlay-helper 'beside a b (image-width a) v-mode)) - -(define (real-overlay name raw-a delta-x delta-y raw-b) - (let ([a (coerce-to-cache-image-snip raw-a)] - [b (coerce-to-cache-image-snip raw-b)]) - (let-values ([(a-w a-h) (snip-size a)] - [(b-w b-h) (snip-size b)]) - (let* ([left (min 0 delta-x)] - [top (min 0 delta-y)] - [right (max (+ delta-x b-w) a-w)] - [bottom (max (+ delta-y b-h) a-h)] - [new-w (inexact->exact (ceiling (- right left)))] - [new-h (inexact->exact (ceiling (- bottom top)))] - [a-dx (inexact->exact (round (- left)))] - [a-dy (inexact->exact (round (- top)))] - [b-dx (inexact->exact (round (- delta-x left)))] - [b-dy (inexact->exact (round (- delta-y top)))] - [combine (lambda (a-f b-f) - (lambda (dc dx dy) - (a-f dc (+ dx a-dx) (+ dy a-dy)) - (b-f dc (+ dx b-dx) (+ dy b-dy))))]) - (check-sizes name new-w new-h) - (new cache-image-snip% - [dc-proc (combine (send a get-dc-proc) - (send b get-dc-proc))] - [argb-proc (combine (send a get-argb-proc) - (send b get-argb-proc))] - [width new-w] - [height new-h] - ;; match what image=? expects, so we don't get false negatives - [px (floor (/ new-w 2))] - [py (floor (/ new-h 2))]))))) - -;; ------------------------------------------------------------ - -(define (clip raw-img delta-w delta-h width height) - (check-image 'clip raw-img "first") - (check-size/0 'clip delta-w "second") - (check-size/0 'clip delta-h "third") - (check-size/0 'clip width "fourth") - (check-size/0 'clip height "fifth") - (let ((delta-w (inexact->exact (floor delta-w))) - (delta-h (inexact->exact (floor delta-h))) - (width (inexact->exact (floor width))) - (height (inexact->exact (floor height)))) - (let ([img (coerce-to-cache-image-snip raw-img)]) - (let-values ([(i-width i-height) (send img get-size)]) - (let* ([dc-proc (send img get-dc-proc)] - [argb-proc (send img get-argb-proc)]) - (new cache-image-snip% - [dc-proc (lambda (dc dx dy) - (let ([clip (send dc get-clipping-region)] - [rgn (make-object region% dc)]) - (send rgn set-rectangle dx dy width height) - (when clip - (send rgn intersect clip)) - (send dc set-clipping-region rgn) - (dc-proc dc (- dx delta-w) (- dy delta-h)) - (send dc set-clipping-region clip)))] - [argb-proc (lambda (argb dx dy) (argb-proc argb (- dx delta-w) (- dy delta-h)))] - [width width] - [height height] - ;; match what image=? expects, so we don't get false negatives - [px (floor (/ width 2))] [py (floor (/ height 2))])))))) - -(define (pad raw-img left right top bottom) - (check-image 'pad raw-img "first") - (check-size/0 'pad left "second") - (check-size/0 'pad right "third") - (check-size/0 'pad top "fourth") - (check-size/0 'pad bottom "fifth") - (let ((left (inexact->exact (floor left))) - (right (inexact->exact (floor right))) - (top (inexact->exact (floor top))) - (bottom (inexact->exact (floor bottom)))) - (let ([img (coerce-to-cache-image-snip raw-img)]) - (let-values ([(i-width i-height) (send img get-size)]) - (let ((width (+ left i-width right)) - (height (+ top i-height bottom))) - (let* ([dc-proc (send img get-dc-proc)] - [argb-proc (send img get-argb-proc)]) - (new cache-image-snip% - [dc-proc (lambda (dc dx dy) - (let ([clip (send dc get-clipping-region)] - [rgn (make-object region% dc)]) - (send rgn set-rectangle dx dy width height) - (when clip - (send rgn intersect clip)) - (send dc set-clipping-region rgn) - (dc-proc dc (+ dx left) (+ dy top)) - (send dc set-clipping-region clip)))] - [argb-proc (lambda (argb dx dy) (argb-proc argb (+ dx left) (+ dy top)))] - [width width] - [height height] - ;; match what image=? expects, so we don't get false negatives - [px (floor (/ width 2))] [py (floor (/ height 2))]))))))) - - -;; ------------------------------------------------------------ - -;; test what happens when the line moves out of the box. -(define (line width height pre-x1 pre-y1 pre-x2 pre-y2 color-in) - (check-size/0 'line width "first") - (check-size/0 'line height "second") - (check-coordinate 'line pre-x1 "third") - (check-coordinate 'line pre-y1 "fourth") - (check-coordinate 'line pre-x2 "fifth") - (check-coordinate 'line pre-y2 "sixth") - (check-image-color 'line color-in "seventh") - (let ((width (inexact->exact (floor width))) - (height (inexact->exact (floor height)))) - (let-values ([(x1 y1 x2 y2) - (if (<= pre-x1 pre-x2) - (values pre-x1 pre-y1 pre-x2 pre-y2) - (values pre-x2 pre-y2 pre-x1 pre-y1))]) - (define do-draw - (lambda (dc dx dy) - (let ([clip (send dc get-clipping-region)] - [rgn (make-object region% dc)]) - (send rgn set-rectangle dx dy width height) - (when clip - (send rgn intersect clip)) - (send dc set-clipping-region rgn) - (send dc draw-line - (+ x1 dx) (+ y1 dy) (+ x2 dx) (+ y2 dy)) - (send dc set-clipping-region clip)))) - - (let ([draw-proc - (make-color-wrapper color-in 'transparent 'solid do-draw)] - [mask-proc - (make-color-wrapper 'black 'transparent 'solid do-draw)]) - (make-simple-cache-image-snip width height draw-proc mask-proc))))) - -(define (text str size color-in) - (check 'text string? str "string" "first") - (check 'text (lambda (x) (and (integer? x) (<= 1 x 255))) size "integer between 1 and 255" "second") - (check-image-color 'text color-in "third") - (cond - [(string=? str "") - (let-values ([(tw th) (get-text-size size "dummyX")]) - (rectangle 0 th 'solid 'black))] - [else - (let ([color (make-color% color-in)]) - (let-values ([(tw th) (get-text-size size str)]) - (let ([draw-proc - (lambda (txt-color mode dc dx dy) - (let ([old-mode (send dc get-text-mode)] - [old-fore (send dc get-text-foreground)] - [old-font (send dc get-font)]) - (send dc set-text-mode mode) - (send dc set-text-foreground txt-color) - (send dc set-font (get-font size)) - (send dc draw-text str dx dy) - (send dc set-text-mode old-mode) - (send dc set-text-foreground old-fore) - (send dc set-font old-font)))]) - (new cache-image-snip% - [dc-proc (lambda (dc dx dy) (draw-proc color 'transparent dc dx dy))] - [argb-proc - (lambda (argb dx dy) - (let ([bm-color - (build-bitmap - (lambda (dc) - (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) - (send dc set-brush (send the-brush-list find-or-create-brush color 'solid)) - (send dc draw-rectangle 0 0 tw th)) - tw - th)] - [bm-mask - (build-bitmap - (lambda (dc) - (draw-proc - (send the-color-database find-color "black") - 'solid dc 0 0)) - tw - th)]) - (overlay-bitmap argb dx dy bm-color bm-mask)))] - [width tw] - [height th] - ;; match what image=? expects, so we don't get false negatives - [px (floor (/ tw 2))] [py (floor (/ th 2))]))))])) - -(define cached-bdc-for-text-size (make-thread-cell #f)) -(define (get-text-size size string) - (unless (thread-cell-ref cached-bdc-for-text-size) - (let* ([bm (make-object bitmap% 1 1)] - [dc (make-object bitmap-dc% bm)]) - (thread-cell-set! cached-bdc-for-text-size dc))) - (let ([dc (thread-cell-ref cached-bdc-for-text-size)]) - (let-values ([(w h _1 _2) (send dc get-text-extent string (get-font size))]) - (values (inexact->exact (ceiling w)) - (inexact->exact (ceiling h)))))) - -(define (get-font size) - (send the-font-list find-or-create-font size - 'default 'normal 'normal #f - (case (system-type) - [(macosx) 'partly-smoothed] - [else 'smoothed]))) - -(define (a-rect/circ do-draw w h color brush pen) - (let* ([dc-proc (make-color-wrapper color brush pen do-draw)] - [mask-proc (make-color-wrapper 'black brush pen do-draw)]) - (make-simple-cache-image-snip w h dc-proc mask-proc))) - -(define (rectangle w h mode color) - (check-size/0 'rectangle w "first") - (check-size/0 'rectangle h "second") - (check-mode 'rectangle mode "third") - (check-image-color 'rectangle color "fourth") - (let ((w (inexact->exact (floor w))) - (h (inexact->exact (floor h)))) - (a-rect/circ (lambda (dc dx dy) (send dc draw-rectangle dx dy w h)) - w h color (mode->brush-symbol mode) (mode->pen-symbol mode)))) - -(define (ellipse w h mode color) - (check-size/0 'ellipse w "first") - (check-size/0 'ellipse h "second") - (check-mode 'ellipse mode "third") - (check-image-color 'ellipse color "fourth") - (let ((w (inexact->exact (floor w))) - (h (inexact->exact (floor h)))) - (a-rect/circ (lambda (dc dx dy) (send dc draw-ellipse dx dy w h)) - w h color (mode->brush-symbol mode) (mode->pen-symbol mode)))) - -(define (circle r mode color) - (check-size/0 'circle r "first") - (check-mode 'circle mode "second") - (check-image-color 'circle color "third") - (let ((r (inexact->exact (floor r)))) - (a-rect/circ (lambda (dc dx dy) (send dc draw-ellipse dx dy (* 2 r) (* 2 r))) - (* 2 r) (* 2 r) color (mode->brush-symbol mode) (mode->pen-symbol mode)))) - -(define (triangle size mode color) - (check 'triangle - (lambda (x) (and (real? x) (< 2 x 10000))) - size - "positive real number bigger than 2" - "first") - (check-mode 'triangle mode "second") - (check-image-color 'triangle color "third") - (let* ([size (inexact->exact (floor size))] - [right (- size 1)] - [bottom (inexact->exact (ceiling (* size (sin (* 2/3 pi)))))] - [points (list (make-object point% 0 bottom) - (make-object point% right bottom) - (make-object point% (/ size 2) 0))]) - (let ([draw (make-color-wrapper - color (mode->brush-symbol mode) 'solid - (lambda (dc dx dy) - (send dc draw-polygon points dx dy)))] - [mask-draw (make-color-wrapper - 'black (mode->brush-symbol mode) 'solid - (lambda (dc dx dy) - (send dc draw-polygon points dx dy)))] - [w size] - [h (+ bottom 1)]) - (make-simple-cache-image-snip w h draw mask-draw)))) - -(define (make-simple-cache-image-snip w h dc-proc mask-proc) - (let ([w (inexact->exact (ceiling w))] - [h (inexact->exact (ceiling h))]) - (let ([argb-proc - (if (or (zero? w) (zero? h)) - void - (lambda (argb-vector dx dy) - (let ([c-bm (build-bitmap (lambda (dc) (dc-proc dc 0 0)) w h)] - [m-bm (build-bitmap (lambda (dc) (mask-proc dc 0 0)) w h)]) - (overlay-bitmap argb-vector dx dy c-bm m-bm))))]) - (new cache-image-snip% - [dc-proc dc-proc] - [argb-proc argb-proc] - [width w] - [height h] - ;; match what image=? expects, so we don't get false negatives - [px (floor (/ w 2))] [py (floor (/ h 2))])))) - -(define (make-color-wrapper color-in brush pen rest) - (let ([color (make-color% color-in)]) - (lambda (dc dx dy) - (let ([old-brush (send dc get-brush)] - [old-pen (send dc get-pen)]) - (send dc set-brush (send the-brush-list find-or-create-brush color brush)) - (send dc set-pen (send the-pen-list find-or-create-pen color 1 pen)) - (rest dc dx dy) - (send dc set-pen old-pen) - (send dc set-brush old-brush))))) - -;; ------------------------------------------------------------ - -(define (image-inside? i a) - (and (locate-image 'image-inside? - (coerce-to-cache-image-snip i) - (coerce-to-cache-image-snip a)) - #t)) - -(define (find-image i a) - (or (locate-image 'find-image - (coerce-to-cache-image-snip i) - (coerce-to-cache-image-snip a)) - (error 'find-image - "the second image does not appear within the first image"))) - -(define (locate-image who i a) - (check-image who i "first") - (check-image who a "second") - (let-values ([(iw ih) (snip-size i)] - [(aw ah) (snip-size a)]) - (and (iw . >= . aw) - (ih . >= . ah) - (let ([i-argb-vector (argb-vector (send i get-argb))] - [a-argb-vector (argb-vector (send a get-argb))]) - (let ([al (let loop ([offset 0]) - (cond - [(= offset (* ah aw 4)) null] - [else (cons (subvector a-argb-vector offset (+ offset (* 4 aw))) - (loop (+ offset (* 4 aw))))]))]) - (let yloop ([dy 0]) - (and (dy . <= . (- ih ah)) - (let xloop ([dx 0]) - (if (dx . <= . (- iw aw)) - (if (let loop ([al al][dd 0]) - (or (null? al) - (and (first-in-second? - i-argb-vector - (car al) - (* 4 (+ (* (+ dy dd) iw) dx))) - (loop (cdr al) (add1 dd))))) - (make-posn dx dy) - (xloop (add1 dx))) - (yloop (add1 dy))))))))))) - -(define (subvector orig i j) - (let ([v (make-vector (- j i) #f)]) - (let loop ([x i]) - (when (< x j) - (vector-set! v (- x i) (vector-ref orig x)) - (loop (+ x 1)))) - v)) -#| -(initial inequalities thanks to Matthew (thanks!!)) - -We know that, for a combination: - m3 = (m1+m2-m1*m2) and - b3 = (m1*b1*(1-m2) + m2*b2)/m3 - -So, we need to figure out what m1 & m2 might have been, -given the other values. - -Check m3: - - m3 = m2 when m1 = 0 - m3 = 1 when m1 = 1 - - [deriv of m3 with respect to m1 = 1 - m2, which is positive] - - so check that m3 is between m2 and 1 - -Then check m3*b3: - - b3*m3 = m2*b2 when m1 = 0 or b1 = 0 - b3*m3 = (1 - m2) + m2*b2 when m1 = b1 = 1 - - [deriv with respect to m1 is b1*(1-m2), which is positive] - [deriv with respect to b1 is m1*(1-m2), which is positive] - - So check that m3*b3 is between m2*b2 and (1 - m2) + m2*b2 - -This is all in alphas from 0 to 1 and needs to be from 255 to 0. -Converting (but using the same names) for the alpha test, we get: - -(<= (- 1 (/ m2 255)) - (- 1 (/ m3 255)) - 1) - -sub1 to each: - -(<= (- (/ m2 255)) - (- (/ m3 255)) - 0) - -mult by 255: - -(<= (- m2) - (- m3) - 0) - -negate and flip ineq: - - -(>= m2 m3 0) - -flip ineq back: - -(<= 0 m3 m2) - - -Here's the original scheme expression for the second check: - -(<= (* m2 b2) - (* m3 b3) - (+ (- 1 m2) (* m2 b2)) - -converting from the computer's coordinates, we get: - - -(<= (* (- 1 (/ m2 255)) (- 1 (/ b2 255))) - (* (- 1 (/ m3 255)) (- 1 (/ b3 255))) - (+ (- 1 (- 1 (/ m2 255))) - (* (- 1 (/ m2 255)) (- 1 (/ b2 255))))) - -;; multiplying out the binomials: - -(<= (+ 1 - (- (/ m2 255)) - (- (/ b2 255)) - (/ (* m2 b2) (* 255 255))) - (+ 1 - (- (/ m3 255)) - (- (/ b3 255)) - (/ (* m3 b3) (* 255 255))) - (+ (- 1 (- 1 (/ m2 255))) - (+ 1 - (- (/ m2 255)) - (- (/ b2 255)) - (/ (* m2 b2) (* 255 255))))) - -;; simplifying the last term - -(<= (+ 1 - (- (/ m2 255)) - (- (/ b2 255)) - (/ (* m2 b2) (* 255 255))) - (+ 1 - (- (/ m3 255)) - (- (/ b3 255)) - (/ (* m3 b3) (* 255 255))) - (+ 1 - (- (/ b2 255)) - (/ (* m2 b2) (* 255 255)))) - -;; multiply thru by 255: - -(<= (+ 255 - (- m2) - (- b2) - (* m2 b2 1/255)) - (+ 255 - (- m3) - (- b3) - (* m3 b3 1/255)) - (+ 255 - (- b2) - (* m2 b2 1/255))) - -;; subtract out 255 from each: - -(<= (+ (- m2) - (- b2) - (* m2 b2 1/255)) - (+ (- m3) - (- b3) - (* m3 b3 1/255)) - (+ (- b2) - (* m2 b2 1/255))) - -;; negate them all, and reverse the inequality - -(>= (+ m2 b2 (* m2 b2 -1/255)) - (+ m3 b3 (* m3 b3 -1/255)) - (+ b2 (* m2 b2 -1/255))) - -;; aka - -(<= (+ b2 (* m2 b2 -1/255)) - (+ m3 b3 (* m3 b3 -1/255)) - (+ m2 b2 (* m2 b2 -1/255))) - -|# - -;; in the above, m3 & b3 come from iv -;; and m2 & b2 come from av -(define (first-in-second? iv av xd) - (let loop ([i (vector-length av)]) - (or (zero? i) - (let ([a (- i 4)] - [r (- i 3)] - [g (- i 2)] - [b (- i 1)]) - (let* ([m2 (vector-ref av a)] - [m3 (vector-ref iv (+ xd a))] - [test - (lambda (b2 b3) - (<= (+ b2 (* m2 b2 -1/255)) - (+ m3 b3 (* m3 b3 -1/255)) - (+ m2 b2 (* m2 b2 -1/255))))]) - (and (<= 0 m3 m2) - (test (vector-ref av r) (vector-ref iv (+ xd r))) - (test (vector-ref av g) (vector-ref iv (+ xd g))) - (test (vector-ref av b) (vector-ref iv (+ xd b))) - (loop (- i 4)))))))) - -;; ---------------------------------------- - -(define (image->color-list i-raw) - (check-image 'image->color-list i-raw "first") - (let* ([cis (coerce-to-cache-image-snip i-raw)] - [i (send cis get-bitmap)]) - (cond - [(not i) '()] - [else - (let* ([iw (send i get-width)] - [ih (send i get-height)] - [new-bitmap (make-object bitmap% iw ih)] - [bdc (make-object bitmap-dc% new-bitmap)]) - (send bdc clear) - (send bdc draw-bitmap i 0 0 'solid - (send the-color-database find-color "black") - (send i get-loaded-mask)) - (let ([is (make-bytes (* 4 iw ih))] - [cols (make-vector (* iw ih))]) - (send bdc get-argb-pixels 0 0 iw ih is) - (let yloop ([y 0][pos 0]) - (unless (= y ih) - (let xloop ([x 0][pos pos]) - (if (= x iw) - (yloop (add1 y) pos) - (begin - (vector-set! cols (+ x (* y iw)) - (make-color (bytes-ref is (+ 1 pos)) - (bytes-ref is (+ 2 pos)) - (bytes-ref is (+ 3 pos)))) - (xloop (add1 x) (+ pos 4))))))) - (send bdc set-bitmap #f) - (vector->list cols)))]))) - -(define (image->alpha-color-list i) - (check-image 'image->alpha-color-list i "first") - (let* ([argb (cond - [(is-a? i image-snip%) - (send (coerce-to-cache-image-snip i) get-argb)] - [(is-a? i cache-image-snip%) (send i get-argb)])] - [v (argb-vector argb)]) - (let loop ([i (vector-length v)] - [a null]) - (cond - [(zero? i) a] - [else (loop (- i 4) - (cons (make-alpha-color - (vector-ref v (- i 4)) - (vector-ref v (- i 3)) - (vector-ref v (- i 2)) - (vector-ref v (- i 1))) - a))])))) - -(define (color-list->image cl in-w in-h) - (check 'color-list->image color-list? cl "list-of-colors" "first") - (check-size/0 'color-list->image in-w "second") - (check-size/0 'color-list->image in-h "third") - (let ([w (inexact->exact in-w)] - [h (inexact->exact in-h)]) - (let ([px (floor (/ w 2))] [py (floor (/ h 2))]) - - (unless (= (* w h) (length cl)) - (error 'color-list->image - "given width times given height is ~a, but the given color list has ~a items" - (* w h) - (length cl))) - - (cond - [(or (equal? w 0) (equal? h 0)) - (rectangle w h 'solid 'black)] - [else - (unless (and (< 0 w 10000) (< 0 h 10000)) - (error 'color-list->image "cannot make ~a x ~a image" w h)) - - (let* ([bm (make-object bitmap% w h)] - [mask-bm (make-object bitmap% w h)] - [dc (make-object bitmap-dc% bm)] - [mask-dc (make-object bitmap-dc% mask-bm)]) - (unless (send bm ok?) - (error (format "cannot make ~a x ~a image" w h))) - (let ([is (make-bytes (* 4 w h) 0)] - [mask-is (make-bytes (* 4 w h) 0)] - [cols (list->vector (map (lambda (x) - (or (make-color% x) - (error 'color-list->image "color ~e is unknown" x))) - cl))]) - (let yloop ([y 0][pos 0]) - (unless (= y h) - (let xloop ([x 0][pos pos]) - (if (= x w) - (yloop (add1 y) pos) - (let* ([col (vector-ref cols (+ x (* y w)))] - [r (pk (send col red))] - [g (pk (send col green))] - [b (pk (send col blue))]) - (bytes-set! is (+ 1 pos) r) - (bytes-set! is (+ 2 pos) g) - (bytes-set! is (+ 3 pos) b) - (when (= 255 r g b) - (bytes-set! mask-is (+ 1 pos) 255) - (bytes-set! mask-is (+ 2 pos) 255) - (bytes-set! mask-is (+ 3 pos) 255)) - (xloop (add1 x) (+ pos 4))))))) - (send dc set-argb-pixels 0 0 w h is) - (send mask-dc set-argb-pixels 0 0 w h mask-is)) - (send dc set-bitmap #f) - (send mask-dc set-bitmap #f) - (bitmaps->cache-image-snip bm mask-bm px py))])))) - -(define (pk col) (min 255 (max 0 col))) - -(define (alpha-color-list->image cl in-w in-h) - (check 'alpha-color-list->image alpha-color-list? cl "list-of-alpha-colors" "first") - (check-size/0 'alpha-color-list->image in-w "second") - (check-size/0 'alpha-color-list->image in-h "third") - (let ([w (inexact->exact in-w)] - [h (inexact->exact in-h)]) - (let ([px (floor (/ w 2))] [py (floor (/ h 2))]) - (unless (= (* w h) (length cl)) - (error 'alpha-color-list->image - "given width times given height is ~a, but the given color list has ~a items" - (* w h) (length cl))) - (cond - [(or (equal? w 0) (equal? h 0)) - (rectangle w h 'solid 'black)] - [else - (unless (and (< 0 w 10000) (< 0 h 10000)) - (error 'alpha-color-list->image format "cannot make ~a x ~a image" w h)) - (let ([index-list (alpha-colors->ent-list cl)]) - (argb->cache-image-snip (make-argb (list->vector index-list) w h) px py))])))) - -;; alpha-colors->ent-list : (listof alpha-color) -> (listof number) -(define (alpha-colors->ent-list cl) - (let loop ([cl cl]) - (cond - [(null? cl) null] - [else - (let ([ac (car cl)]) - (list* (alpha-color-alpha ac) - (alpha-color-red ac) - (alpha-color-green ac) - (alpha-color-blue ac) - (loop (cdr cl))))]))) - -(define empty-image - (make-simple-cache-image-snip 0 0 void void)) - -(define octet (signature (combined natural (predicate (lambda (n) (<= n 255)))))) -(define rgb-color (signature (predicate color?))) -(define alpha-rgb-color (signature (predicate alpha-color?))) -(define mode (signature (one-of "solid" "outline"))) -(define image (signature (predicate image?))) -(define image-color (signature (predicate image-color?))) -(define h-place (signature (mixed integer (one-of "left" "right" "center")))) -(define v-place (signature (mixed integer (one-of "top" "bottom" "center")))) -(define h-mode (signature (one-of "left" "right" "center"))) -(define v-mode (signature (one-of "top" "bottom" "center"))) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/info.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/info.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -2,16 +2,18 @@ (define name "DeinProgramm") -(define tools '("deinprogramm-langs.rkt")) +(define tools '("sdp/private/sdp-langs.rkt" "DMdA/private/DMdA-langs.rkt")) -(define tool-icons '(("logo-small.png" "deinprogramm"))) -(define tool-names '("DeinProgramm")) -(define tool-urls '("http://www.deinprogramm.de/dmda/")) +(define tool-icons '(("logo-small.png" "deinprogramm") ("dmda-logo.png" "deinprogramm"))) +(define tool-names '("DeinProgramm" "DeinProgramm")) +(define tool-urls '("http://www.deinprogramm.de/" "http://www.deinprogramm.de/dmda/")) (define compile-omit-paths - '("define-record-procedures.scm" - "convert-explicit.scm" - "line3d.scm")) + '("DMdA/define-record-procedures.scm" + "DMdA/private/convert-explicit.scm" + "DMdA/teachpack/line3d.scm" + "sdp/record.scm" + "sdp/private/convert-explicit.scm")) (define test-omit-paths compile-omit-paths) (define get-textbook-pls diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/line3d.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/line3d.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/line3d.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/line3d.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,60 +0,0 @@ -(module line3d mzscheme - (require "world.rkt" - "define-record-procedures.rkt") - (require (only "DMdA-vanilla.rkt" - empty make-pair empty? - first rest)) - (provide make-vec3 - vec3-x - vec3-y - vec3-z - add-vec3 - sub-vec3 - mult-vec3 - div-vec3 - dotproduct-vec3 - normquad-vec3 - norm-vec3 - normalize-vec3 - crossproduct-vec3 - make-vec4 - vec4-x - vec4-y - vec4-z - vec4-w - add-vec4 - sub-vec4 - mult-vec4 - div-vec4 - dotproduct-vec4 - normquad-vec4 - norm-vec4 - normalize-vec4 - expand-vec3 - make-matrix4x4 - create-matrix4x4 - transpose-matrix4x4 - multiply-matrix-vec4 - transform-vec3 - multiply-matrix - create-translation-matrix - create-rotation-x-matrix - create-rotation-y-matrix - create-rotation-z-matrix - print-vec4 - print-matrix4x4 - create-lookat-matrix - create-projection-matrix - create-viewport-matrix - create-camera-matrix - make-line3d - line3d-a - line3d-b - line3d-color - create-box - transform-primitive-list - render-scene - ) - - (require mzlib/include) - (include "line3d.scm")) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/line3d.scm racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/line3d.scm --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/line3d.scm 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/line3d.scm 1970-01-01 00:00:00.000000000 +0000 @@ -1,510 +0,0 @@ -;; ############################################### -;; ############################################### -;; -;; Mini-3D-Engine -;; -;; 3D-Object are represented with line primitives -;; -;; Martin Bokeloh, Sebastian Veith -;; ############################################### -;; ############################################### - - -;; ----------------------------------- -;; some linear algebra tools -;; ----------------------------------- - -;; 3D-vector -(define-record-procedures vec3 - make-vec3 vec3? - (vec3-x - vec3-y - vec3-z)) - -;; return a+b -;; add-vec3 : vec3 vec3 -> vec3 -(define add-vec3 - (lambda (a b) - (make-vec3 - (+ (vec3-x a) (vec3-x b)) - (+ (vec3-y a) (vec3-y b)) - (+ (vec3-z a) (vec3-z b))))) - -;; return a-b -;; sub-vec3 : vec3 vec3 -> vec3 -(define sub-vec3 - (lambda (a b) - (make-vec3 - (- (vec3-x a) (vec3-x b)) - (- (vec3-y a) (vec3-y b)) - (- (vec3-z a) (vec3-z b))))) - -;; return v*s -;; mult-vec3 : vec3 number -> vec3 -(define mult-vec3 - (lambda (v s) - (make-vec3 - (* (vec3-x v) s) - (* (vec3-y v) s) - (* (vec3-z v) s)))) - -;; return v/s -;; div-vec3 : vec3 number -> vec3 -(define div-vec3 - (lambda (v s) - (mult-vec3 v (/ 1 s)))) - -;; return a*b -;; dotproduct-vec3 : vec3 vec3 -> Number -(define dotproduct-vec3 - (lambda (a b) - (+ - (* (vec3-x a) (vec3-x b)) - (* (vec3-y a) (vec3-y b)) - (* (vec3-z a) (vec3-z b))))) - -;; compute quadratic euclidian norm -;; normquad-vec3 : vec3 -> Number -(define normquad-vec3 - (lambda (a) - (+ - (* (vec3-x a) (vec3-x a)) - (* (vec3-y a) (vec3-y a)) - (* (vec3-z a) (vec3-z a))))) - -;; compute euclidian norm -;; norm-vec3 : vec3 -> Number -(define norm-vec3 - (lambda (a) - (sqrt (normquad-vec3 a)))) - -;; normalize vector -;; normalize-vec3 : vec3 -> vec3 -(define normalize-vec3 - (lambda (a) - (div-vec3 a (norm-vec3 a)))) - -;; cross product (computes a vector perpendicular to both input vectors) -;; crossproduct-vec3 : vec3 vec3 -> vec3 -(define crossproduct-vec3 - (lambda (a b) - (make-vec3 - (- (* (vec3-y a) (vec3-z b)) (* (vec3-z a) (vec3-y b))) - (- (* (vec3-z a) (vec3-x b)) (* (vec3-x a) (vec3-z b))) - (- (* (vec3-x a) (vec3-y b)) (* (vec3-y a) (vec3-x b)))))) - -;; 4D-vector -(define-record-procedures vec4 - make-vec4 vec4? - (vec4-x - vec4-y - vec4-z - vec4-w)) - -;; expands a 3d-vector to a 4d-vector (v,s) -;; expand-vec3 : vec3 number -> vec4 -(define expand-vec3 - (lambda (v s) - (make-vec4 (vec3-x v) (vec3-y v) (vec3-z v) s))) - -;; return a+b -;; add-vec4 : vec4 vec4 -> vec4 -(define add-vec4 - (lambda (a b) - (make-vec4 - (+ (vec4-x a) (vec4-x b)) - (+ (vec4-y a) (vec4-y b)) - (+ (vec4-z a) (vec4-z b)) - (+ (vec4-w a) (vec4-w b))))) - -;; return a-b -;; sub-vec4 : vec4 vec4 -> vec4 -(define sub-vec4 - (lambda (a b) - (make-vec4 - (- (vec4-x a) (vec4-x b)) - (- (vec4-y a) (vec4-y b)) - (- (vec4-z a) (vec4-z b)) - (- (vec4-w a) (vec4-w b))))) - -;; return v*s -;; mult-vec4 : vec4 number -> vec4 -(define mult-vec4 - (lambda (v s) - (make-vec4 - (* (vec4-x v) s) - (* (vec4-y v) s) - (* (vec4-z v) s) - (* (vec4-w v) s)))) - -;; return v/s -;; div-vec4 : vec4 number -> vec4 -(define div-vec4 - (lambda (v s) - (mult-vec4 v (/ 1 s)))) - -;; return a*b -;; dotproduct-vec4 : vec4 vec4 -> Number -(define dotproduct-vec4 - (lambda (a b) - (+ - (* (vec4-x a) (vec4-x b)) - (* (vec4-y a) (vec4-y b)) - (* (vec4-z a) (vec4-z b)) - (* (vec4-w a) (vec4-w b))))) - -;; compute quadratic euclidian norm -;; normquad-vec4 : vec4 -> Number -(define normquad-vec4 - (lambda (a) - (+ - (* (vec4-x a) (vec4-x a)) - (* (vec4-y a) (vec4-y a)) - (* (vec4-z a) (vec4-z a)) - (* (vec4-w a) (vec4-w a))))) - -;; compute euclidian norm -;; norm-vec4 : vec4 -> Number -(define norm-vec4 - (lambda (a) - (sqrt (normquad-vec4 a)))) - -;; normalize vector -;; normalize-vec4 : vec4 -> vec4 -(define normalize-vec4 - (lambda (a) - (/ a (norm-vec4 a)))) - -;; 4x4 matrix (implemented with 4 row vectors; vec4) -(define-record-procedures matrix4x4 - make-matrix4x4 matrix4x4? - (matrix4x4-1 - matrix4x4-2 - matrix4x4-3 - matrix4x4-4)) - -;; create 4x4 from 4 3d-vectors -;; create-matrix4x4 : vec3 vec3 vec3 vec3 -> matrix4x4 -(define create-matrix4x4 - (lambda (v1 v2 v3 v4) - (make-matrix4x4 - (expand-vec3 v1 0 ) - (expand-vec3 v2 0 ) - (expand-vec3 v3 0 ) - (expand-vec3 v4 1 )))) - -;; return a^T -;; transpose-matrix4x4 : matrix4x4 -> matrix4x4 -(define transpose-matrix4x4 - (lambda (a) - (make-matrix4x4 - (make-vec4 (vec4-x (matrix4x4-1 a)) - (vec4-x (matrix4x4-2 a)) - (vec4-x (matrix4x4-3 a)) - (vec4-x (matrix4x4-4 a))) - (make-vec4 (vec4-y (matrix4x4-1 a)) - (vec4-y (matrix4x4-2 a)) - (vec4-y (matrix4x4-3 a)) - (vec4-y (matrix4x4-4 a))) - (make-vec4 (vec4-z (matrix4x4-1 a)) - (vec4-z (matrix4x4-2 a)) - (vec4-z (matrix4x4-3 a)) - (vec4-z (matrix4x4-4 a))) - (make-vec4 (vec4-w (matrix4x4-1 a)) - (vec4-w (matrix4x4-2 a)) - (vec4-w (matrix4x4-3 a)) - (vec4-w (matrix4x4-4 a)))))) - -;; multiply 4x4 matrix with vec4 -;; multiply-matrix-vec4 : matrix4x4 vec4 -> vec4 -(define multiply-matrix-vec4 - (lambda (m v) - (make-vec4 (dotproduct-vec4 (matrix4x4-1 m) v) - (dotproduct-vec4 (matrix4x4-2 m) v) - (dotproduct-vec4 (matrix4x4-3 m) v) - (dotproduct-vec4 (matrix4x4-4 m) v)))) - -;; multiply homogenous matrix with (vec3,1) and project onto plane w=1 -;; transform-vec3 : matrix4x4 vec3 -> vec3 -(define transform-vec3 - (lambda (m v) - (let ((v4 (make-vec4 (vec3-x v) (vec3-y v) (vec3-z v) 1))) - (div-vec3 (make-vec3 (dotproduct-vec4 (matrix4x4-1 m) v4) - (dotproduct-vec4 (matrix4x4-2 m) v4) - (dotproduct-vec4 (matrix4x4-3 m) v4)) - (dotproduct-vec4 (matrix4x4-4 m) v4))))) - - -;; return a*b -;; multiply-matrix : matrix4x4 matrix4x4 -> matrix4x4 -(define multiply-matrix - (lambda (a b) - (let ( (b^T (transpose-matrix4x4 b)) ) - (make-matrix4x4 - (make-vec4 (dotproduct-vec4 (matrix4x4-1 a) (matrix4x4-1 b^T)) - (dotproduct-vec4 (matrix4x4-1 a) (matrix4x4-2 b^T)) - (dotproduct-vec4 (matrix4x4-1 a) (matrix4x4-3 b^T)) - (dotproduct-vec4 (matrix4x4-1 a) (matrix4x4-4 b^T))) - (make-vec4 (dotproduct-vec4 (matrix4x4-2 a) (matrix4x4-1 b^T)) - (dotproduct-vec4 (matrix4x4-2 a) (matrix4x4-2 b^T)) - (dotproduct-vec4 (matrix4x4-2 a) (matrix4x4-3 b^T)) - (dotproduct-vec4 (matrix4x4-2 a) (matrix4x4-4 b^T))) - (make-vec4 (dotproduct-vec4 (matrix4x4-3 a) (matrix4x4-1 b^T)) - (dotproduct-vec4 (matrix4x4-3 a) (matrix4x4-2 b^T)) - (dotproduct-vec4 (matrix4x4-3 a) (matrix4x4-3 b^T)) - (dotproduct-vec4 (matrix4x4-3 a) (matrix4x4-4 b^T))) - (make-vec4 (dotproduct-vec4 (matrix4x4-4 a) (matrix4x4-1 b^T)) - (dotproduct-vec4 (matrix4x4-4 a) (matrix4x4-2 b^T)) - (dotproduct-vec4 (matrix4x4-4 a) (matrix4x4-3 b^T)) - (dotproduct-vec4 (matrix4x4-4 a) (matrix4x4-4 b^T))))))) - -;; create a matrix which translates (moves) by a 3d-vector -;; create-translation-matrix: vec3 -> matrix4x4 -(define create-translation-matrix - (lambda (translation) - (make-matrix4x4 - (make-vec4 1 0 0 (vec3-x translation)) - (make-vec4 0 1 0 (vec3-y translation)) - (make-vec4 0 0 1 (vec3-z translation)) - (make-vec4 0 0 0 1)))) - -;; create a matrix which rotates around the x-axis -;; create-rotation-x-matrix: Number -> matrix4x4 -(define create-rotation-x-matrix - (lambda (angle) - (make-matrix4x4 - (make-vec4 1 0 0 0) - (make-vec4 0 (cos angle) (sin angle) 0) - (make-vec4 0 (-(sin angle)) (cos angle) 0) - (make-vec4 0 0 0 1)))) - -;; create a matrix which rotates around the y-axis -;; create-rotation-y-matrix: Number -> matrix4x4 -(define create-rotation-y-matrix - (lambda (angle) - (make-matrix4x4 - (make-vec4 (cos angle) 0 (sin angle) 0) - (make-vec4 0 1 0 0) - (make-vec4 (-(sin angle)) 0 (cos angle) 0) - (make-vec4 0 0 0 1)))) - -;; create a matrix which rotates around the z-axis -;; create-rotation-z-matrix: Number -> matrix4x4 -(define create-rotation-z-matrix - (lambda (angle) - (make-matrix4x4 - (make-vec4 (cos angle) (sin angle) 0 0) - (make-vec4 (-(sin angle)) (cos angle) 0 0) - (make-vec4 0 0 1 0) - (make-vec4 0 0 0 1)))) - -(define PI 3.14159265) -(define PI/2 (/ PI 2)) -(define PI/4 (/ PI 4)) - -; output a vector -; print-vec4 : vec4 -> string -(define print-vec4 - (lambda (v) - (string-append (number->string (vec4-x v)) "\t" - (number->string (vec4-y v)) "\t" - (number->string (vec4-z v)) "\t" - (number->string (vec4-w v))))) - -; output a matrix -; print-matrix4x4 : matrix4x4 -> string -(define print-matrix4x4 - (lambda (m) - (let ((m^T (transpose-matrix4x4 m))) - (string-append (print-vec4 (matrix4x4-1 m^T)) "\n" - (print-vec4 (matrix4x4-2 m^T)) "\n" - (print-vec4 (matrix4x4-3 m^T)) "\n" - (print-vec4 (matrix4x4-4 m^T)) "\n")))) - -;; --------------------------------------------- -;; camera and projection -;; --------------------------------------------- - -; create a look-at modelview matrix -; M = (v1 v2 v3 v4) -; (0 0 0 1 ) -; v1 = (lookat - position) x upvector -; v2 = ((lookat - position) x upvector) x (lookat - position) -; v3 = (lookat - position) -; v4 = (0 0 0) -; create-lookat-matrix : vec3 vec3 vec3 -> matrix4x4 -(define create-lookat-matrix - (lambda (position lookat upvector) - (let* ((viewdirection (normalize-vec3 (sub-vec3 position lookat))) - (normed-upvector (normalize-vec3 upvector)) - (rightvector (crossproduct-vec3 viewdirection normed-upvector))) - (multiply-matrix - (create-matrix4x4 - (normalize-vec3 rightvector) - (normalize-vec3 (crossproduct-vec3 rightvector viewdirection)) - viewdirection - (make-vec3 0 0 0)) - (create-translation-matrix (mult-vec3 position -1)))))) - -; projection with a specified vertical viewing angle -; create-projection-matrix : number -> matrix4x4 -(define create-projection-matrix - (lambda (vertical-fov/2) - (let ((f (/ (cos vertical-fov/2) (sin vertical-fov/2)))) - (make-matrix4x4 - (make-vec4 f 0 0 0) - (make-vec4 0 f 0 0) - (make-vec4 0 0 0 0) - (make-vec4 0 0 1 0))))) - -; transforms camera-space into image-space -; create-viewport-matrix : number number -> number -(define create-viewport-matrix - (lambda (screenwidth screenheight) - (let ((screenwidth/2 (/ screenwidth 2)) - (screenheight/2 (/ screenheight 2))) - (make-matrix4x4 - (make-vec4 screenwidth/2 0 0 screenwidth/2) - (make-vec4 0 screenheight/2 0 screenheight/2) - (make-vec4 0 0 1/2 0) - (make-vec4 0 0 0 1))))) - -; create a complete camera matrix -; create-camera-matrix : -(define create-camera-matrix - (lambda (position lookat vertical-fov screenwidth screenheight) - (multiply-matrix - (multiply-matrix - (create-viewport-matrix screenwidth screenheight) - (create-projection-matrix (* (/ vertical-fov 360) PI))) - (create-lookat-matrix position lookat (make-vec3 0 1 0))))) - -;; ---------------------------------------------- -;; scene -;; ---------------------------------------------- - -; defines a colored line between two points (3D) -(define-record-procedures line3d - make-line3d line3d? - (line3d-a line3d-b line3d-color)) - -; creates a box centered at (0,0,0) with the given dimensions. -; create-box : number number number color -> list(line3d) -(define create-box - (lambda (width height depth color) - (let ((corner1 (make-vec3 (- width) (- height) (- depth))) - (corner2 (make-vec3 width (- height) (- depth))) - (corner3 (make-vec3 width height (- depth))) - (corner4 (make-vec3 (- width) height (- depth))) - (corner5 (make-vec3 (- width) (- height) depth)) - (corner6 (make-vec3 width (- height) depth)) - (corner7 (make-vec3 width height depth)) - (corner8 (make-vec3 (- width) height depth))) - (list - (make-line3d corner1 corner2 color) - (make-line3d corner2 corner3 color) - (make-line3d corner3 corner4 color) - (make-line3d corner4 corner1 color) - (make-line3d corner5 corner6 color) - (make-line3d corner6 corner7 color) - (make-line3d corner7 corner8 color) - (make-line3d corner8 corner5 color) - (make-line3d corner1 corner5 color) - (make-line3d corner1 corner5 color) - (make-line3d corner2 corner6 color) - (make-line3d corner3 corner7 color) - (make-line3d corner4 corner8 color))))) - -; apply transformation to every given line -; transform-primitive-list: list(line3d) matrix4x4 -> list(line3d) -(define transform-primitive-list - (lambda (l mat) - (cond - ((pair? l) (transform-primitive-list-helper l mat empty)) - ((empty? l) empty)))) - -; transform-primitive-list-helper : list(line3d) matrix4x4 list(line3d) -> list(line3d) -(define transform-primitive-list-helper - (lambda (l mat result) - (cond - ((pair? l) - (transform-primitive-list-helper (rest l) mat - (make-pair (make-line3d (transform-vec3 mat (line3d-a (first l))) - (transform-vec3 mat (line3d-b (first l))) - (line3d-color (first l))) result))) - ((empty? l) result)))) - -;; --------------------------------------------- -;; rendering -;; --------------------------------------------- - -; w-clip epsilon -(define clip-epsilon -0.1) - -;; clip line on plane w=clip-epsilon -;; clipline: vec4 vec4 color -> image -(define clipline - (lambda (screenWidth screenHeight inside outside color) - (let* ((delta-vec (sub-vec4 outside inside)) - (f (/ (- clip-epsilon (vec4-w inside)) (- (vec4-w outside) (vec4-w inside)))) - ; compute intersection with clipping plane - (clipped-point (add-vec4 inside (mult-vec4 delta-vec f))) - ; project points by normalising to w=1 - (inside-projected (div-vec4 inside (vec4-w inside))) - (clipped-point-projected (div-vec4 clipped-point (vec4-w clipped-point)))) - (line screenWidth screenHeight (vec4-x inside-projected) (vec4-y inside-projected) - (vec4-x clipped-point-projected) (vec4-y clipped-point-projected) color)))) - - -; render line with clipping -; render-clipped-line3d : N N vec4 vec4 matrix4x4 -> image -(define render-clipped-line3d - (lambda (screenWidth screenHeight l camera-matrix) - (let* ((point-a (line3d-a l)) - (point-b (line3d-b l)) - (point-a-transformed (multiply-matrix-vec4 camera-matrix - (make-vec4 (vec3-x point-a) (vec3-y point-a) (vec3-z point-a) 1))) - (point-b-transformed (multiply-matrix-vec4 camera-matrix - (make-vec4 (vec3-x point-b) (vec3-y point-b) (vec3-z point-b) 1))) - (projected-point1 (transform-vec3 camera-matrix (line3d-a l))) - (projected-point2 (transform-vec3 camera-matrix (line3d-b l)))) - (cond - ((and (< (vec4-w point-a-transformed) clip-epsilon) - (< (vec4-w point-b-transformed) clip-epsilon)) - (line screenWidth screenHeight (vec3-x projected-point1) (vec3-y projected-point1) - (vec3-x projected-point2) (vec3-y projected-point2) (line3d-color l))) - ((and (>= (vec4-w point-a-transformed) clip-epsilon) - (< (vec4-w point-b-transformed) clip-epsilon)) - (clipline screenWidth screenHeight point-b-transformed point-a-transformed (line3d-color l))) - ((and (>= (vec4-w point-b-transformed) clip-epsilon) - (< (vec4-w point-a-transformed) clip-epsilon)) - (clipline screenWidth screenHeight point-a-transformed point-b-transformed (line3d-color l))) - (else (line screenWidth screenHeight -1 0 0 0 (line3d-color l))))))) - -; render line without clipping (not used anymore) -; render-line3d : N N line3d matrix4x4 -> image -(define render-line3d - (lambda (screenWidth screenHeight l camera-matrix) - (let ((projected-point1 (transform-vec3 camera-matrix (line3d-a l))) - (projected-point2 (transform-vec3 camera-matrix (line3d-b l)))) - (line screenWidth screenHeight (vec3-x projected-point1) (vec3-y projected-point1) - (vec3-x projected-point2) (vec3-y projected-point2) (line3d-color l))))) - -; render scene into an image -; render-scene: N N list(line3d) matrix4x4 -> image -(define render-scene - (lambda (screenWidth screenHeight scene camera-matrix) - (cond - ((empty? scene)(line screenWidth screenHeight 0 0 0 0 "white")) - ((pair? scene) - (render-scene-helper screenWidth screenHeight (rest scene) camera-matrix - (render-clipped-line3d screenWidth screenHeight (first scene) camera-matrix)))))) - -; render-scene-helper: list(line3d) matrix4x4 image -> image -(define render-scene-helper - (lambda (screenWidth screenHeight scene camera-matrix screen) - (cond - ((empty? scene) screen) - ((pair? scene) (render-scene-helper screenWidth screenHeight (rest scene) camera-matrix - (overlay screen - (render-clipped-line3d screenWidth screenHeight (first scene) camera-matrix) 0 0)))))) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/private/syntax-checkers.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/private/syntax-checkers.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/private/syntax-checkers.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/private/syntax-checkers.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,20 @@ +#lang scheme/base + +(provide check-for-id! + check-for-id-list!) + +(define (check-for-id! arg error-msg) + (when (not (identifier? arg)) + (raise-syntax-error #f error-msg arg))) + +(define (check-for-id-list! args error-msg) + (for-each (lambda (arg) + (check-for-id! arg error-msg)) + args) + (cond ((check-duplicate-identifier args) + => (lambda (dup) + (raise-syntax-error + #f + "Name doppelt gebunden" + args dup))) + (else #t))) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/advanced.scrbl racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/advanced.scrbl --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/advanced.scrbl 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/advanced.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,103 @@ +#lang scribble/doc +@(require scribblings/htdp-langs/common "std-grammar.rkt" "prim-ops.rkt" + (for-label deinprogramm/sdp/advanced)) + +@title[#:style 'toc #:tag "sdp-advanced"]{Schreibe Dein Programm! - fortgeschritten} + +This is documentation for the language level @italic{Schreibe Dein Programm +- fortgeschritten} that goes with the German textbook +@italic{Schreibe Dein Programm!}. + +@declare-exporting[deinprogramm/sdp/advanced] + +@racketgrammar*-sdp[ +#:literals () +( +) +( + [field-spec id (id id)] + [quoted id + number + string + character + symbol + (quoted ...) + @#,elem{@racketvalfont{'}@racket[quoted]}] +) +( + @#,racket[(let ((id expr) (... ...)) expr)] + @#,racket[(letrec ((id expr) (... ...)) expr)] + @#,racket[(let* ((id expr) (... ...)) expr) ] + quoted + (code:line @#,elem{@racketvalfont{'}@racket[quoted]} (code:comment @#,seclink["advanced-quote"]{Quote-Literal})) +) +( + @#,racket[(list-of sig)] + @#,racket[(nonempty-list-of sig)] +) +( + @#,racket[(make-pair pattern pattern)] + @#,racket[(list pattern ...)] + @#,elem{@racketvalfont{'}@racket[quoted]} +) +] + +@|prim-nonterms| + +@prim-ops['(lib "advanced.rkt" "deinprogramm" "sdp") #'here] + +@section[#:tag "advanced-quote"]{Quote-Literal} + +@deftogether[( +@defform/none[(unsyntax @elem{@racketvalfont{'}@racket[quoted]})] +@defform[(quote quoted)] +)]{ +Der Wert eines Quote-Literals hat die gleiche externe Repräsentation wie @racket[quoted]. +} + +@section[#:tag "advanced-signatures"]{Signaturen} + +@defidform[symbol]{ +Signatur für Symbole. +} + +@section[#:tag "pattern-matching-advanced"]{Pattern-Matching} + +@defform/none[(match expr (pattern expr) ...) + #:grammar [(pattern + ... + @#,elem{@racketvalfont{'}@racket[quoted]} + )]]{ +Zu den Patterns kommt noch eins hinzu: + +@itemlist[ +@item{Das Pattern @racketvalfont{'}@racket[quoted] paßt auf genau auf Werte, welche +die gleiche externe Repräsentation wie @racket[quoted] haben.} +] +} + +@section[#:tag "advanced-definitions"]{Definitionen} +@declare-exporting[deinprogramm/sdp/deflam] + +@defform[(define id expr)]{Diese Form ist wie in den unteren +Sprachebenen.} + +@section[#:tag "advanced-lambda"]{@racket[lambda] / @racket[λ]} +@declare-exporting[deinprogramm/sdp/deflam] + +@defform[(lambda (id id ... . id) expr)]{ +Bei @racket[lambda] ist in +dieser Sprachebene in einer Form zulässig, die es erlaubt, eine +Prozedur mit einer variablen Anzahl von Paramern zu erzeugen: Alle +Parameter vor dem Punkt funktionieren wie gewohnt und werden jeweils +an die entsprechenden Argumente gebunden. Alle restlichen Argumente +werden in eine Liste verpackt und an den Parameter nach dem Punkt +gebunden.} + +@defform[(λ (id id ... . id) expr)]{ +@racket[λ] ist ein anderer Name für @racket[lambda]. +} + +@section[#:tag "advanced-prim-op"]{Primitive Operationen} + +@prim-op-defns['(lib "advanced.rkt" "deinprogramm" "sdp") #'here '()] diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/beginner.scrbl racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/beginner.scrbl --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/beginner.scrbl 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/beginner.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,475 @@ +#lang scribble/doc +@(require scribblings/htdp-langs/common scribble/struct + "std-grammar.rkt" "prim-ops.rkt" + (for-label deinprogramm/sdp/beginner)) + +@title[#:style 'toc #:tag "sdp-beginner"]{Schreibe Dein Programm! - Anfänger} + +This is documentation for the language level @italic{Schreibe Dein Programm! +- Anfänger} to go with the German textbook +@italic{Schreibe Dein Programm!}. + +@declare-exporting[deinprogramm/sdp/beginner #:use-sources (deinprogramm/sdp/private/primitives deinprogramm/sdp/record)] + +@racketgrammar*-sdp[ +#:literals () +() () () () () +] + +@|prim-nonterms| + +@prim-ops['(lib "beginner.rkt" "deinprogramm" "sdp") #'here] + +@; ---------------------------------------------------------------------- + +@section{Definitionen} + +@defform[(define id expr)]{ +Diese Form ist eine Definition, und bindet @racket[id] als +globalen Namen an den Wert von @racket[expr].} + +@section{Record-Typ-Definitionen} + +@defform*[((define-record-functions t c p (sel sig) ...) + (define-record-functions t c (sel sig) ...))]{ + +Die @racket[define-record-functions]-Form ist eine Definition +für einen neuen Record-Typ. Dabei ist @racket[t] der Name der Record-Signatur, +@racket[c] der Name des Konstruktors und @racket[p] +der (optionale) Name des Prädikats. + +Jedes @racket[(sel sig)] beschreibt ein @italic{Feld} des +Record-Typs, wobei @racket[sel] +der Name des Selektors für das Feld und @racket[sig] die Signatur des Feldes ist. +} + +@section[#:tag "application"]{Prozedurapplikation} + +@defform/none[(expr expr ...)]{ +Dies ist eine Prozeduranwendung oder Applikation. +Alle @racket[expr]s werden ausgewertet: +Der Operator (also der erste Ausdruck) muß eine +Prozedur ergeben, die genauso viele Argumente +akzeptieren kann, wie es Operanden, also weitere @racket[expr]s gibt. +Die Anwendung wird dann ausgewertet, indem der Rumpf +der Applikation ausgewertet wird, nachdem die Parameter +der Prozedur durch die Argumente, also die Werte der +Operanden ersetzt wurden.} + +@; @defform[(#%app id expr expr ...)]{ +@; +@; Eine Prozedurapplikation kann auch mit @racket[#%app] geschrieben +@; werden, aber das macht eigentlich niemand.} + +@section{@racket[#t] and @racket[#f]} + +@as-index{@litchar{#t}} ist das Literal für den booleschen Wert "wahr", +@as-index{@litchar{#f}} das Literal für den booleschen Wert "falsch". + +@section{@racket[lambda] / @racket[λ]} + +@defform[(lambda (id ...) expr)]{ +Ein Lambda-Ausdruck ergibt bei der Auswertung eine neue Prozedur.} + +@defform[(λ (id ...) expr)]{ +@racket[λ] ist ein anderer Name für @racket[lambda]. +} + +@section[#:tag "id"]{Bezeichner} + +@defform/none[id]{ +Eine Variable bezieht sich auf die, von innen nach +außen suchend, nächstgelegene Bindung durch @racket[lambda], @racket[let], @racket[letrec], oder +@racket[let*]. Falls es keine solche lokale Bindung gibt, muß es eine +Definition oder eine eingebaute Bindung mit dem entsprechenden Namen +geben. Die Auswertung des Namens ergibt dann den entsprechenden +Wert. } + +@section{@racket[cond]} + +@defform[(cond (expr expr) ... (expr expr))]{ +Ein @racket[cond]-Ausdruck bildet eine Verzweigung, die aus mehreren +Zweigen besteht. Jeder Zweig besteht +aus einem Test und einem Ausdruck. Bei der Auswertung werden die +Zweige nacheinander abgearbeitet. Dabei wird jeweils zunächst der Test +ausgewertet, der jeweils einen booleschen Wert ergeben müssen. Beim +ersten Test, der @racket[#t] ergibt, wird der Wert des Ausdrucks des Zweigs zum +Wert der gesamten Verzweigung. Wenn kein Test @racket[#t] ergibt, wird das +Programm mit einer Fehlermeldung abgebrochen. +} + +@defform/none[#:literals (cond else) + (cond (expr expr) ... (else expr))]{ + Die Form des @racket[cond]-Ausdrucks ist ähnlich zur vorigen, mit der + Ausnahme, daß in dem Fall, in dem kein Test @racket[#t] ergibt, der Wert des + letzten Ausdruck zum Wert der @racket[cond]-Form wird. +} + +@defidform[else]{ + +Das Schlüsselwort @racket[else] kann nur in @racket[cond] benutzt werden.} + +@; ---------------------------------------------------------------------- + +@section{@racket[if]} + +@defform[(if expr expr expr)]{ +Eine @racket[if]-Form ist eine binäre Verzweigung. Bei der Auswertung wird +zunächst der erste Operand ausgewertet (der Test), der einen +booleschen Wert ergeben muß. Ergibt er @racket[#t], wird der Wert des zweiten +Operanden (die Konsequente) zum Wert der @racket[if]-Form, bei @racket[#f] der Wert des +dritten Operanden (die Alternative). +} + +@; ---------------------------------------------------------------------- + +@section{@racket[and]} + +@defform[(and expr ...)]{ +Bei der Auswertung eines @racket[and]-Ausdrucks werden nacheinander die +Operanden (die boolesche Werte ergeben müssen) ausgewertet. Ergibt +einer @racket[#f], ergibt auch der and-Ausdruck @racket[#f]; wenn alle +Operanden @racket[#t] ergeben, ergibt auch der @racket[and]-Ausdruck +@racket[#t]. +} + +@; ---------------------------------------------------------------------- + +@section{@racket[or]} + +@defform[(or expr ...)]{ +Bei der Auswertung eines @racket[or]-Ausdrucks werden nacheinander die +Operanden (die boolesche Werte ergeben müssen) ausgewertet. Ergibt +einer @racket[#t], ergibt auch der or-Ausdruck @racket[#t]; wenn alle Operanden @racket[#f] +ergeben, ergibt auch der @racket[or]-Ausdruck @racket[#f]. +} + +@section{Signaturen} + +Signaturen können statt der Verträge aus dem Buch geschrieben werden: +Während Verträge reine Kommentare sind, überprüft DrRacket Signaturen +und meldet etwaige Verletzungen. + +@subsection{@racket[signature]} +@defform[(signature sig)]{ +Diese Form liefert die Signatur mit der Notation @racket[sig]. +} + +@subsection{Signaturdeklaration} +@defform[(: id sig)]{ +Diese Form erklärt @racket[sig] zur gültigen Signatur für @racket[id]. +} + +@subsection{Eingebaute Signaturen} + +@defidform[number]{ +Signatur für beliebige Zahlen. +} + +@defidform[real]{ +Signatur für reelle Zahlen. +} + +@defidform[rational]{ +Signatur für rationale Zahlen. +} + +@defidform[integer]{ +Signatur für ganze Zahlen. +} + +@defidform[natural]{ +Signatur für ganze, nichtnegative Zahlen. +} + +@defidform[boolean]{ +Signatur für boolesche Werte. +} + +@defidform[true]{ +Signatur für \scheme[#t]. +} + +@defidform[false]{ +Signatur für \scheme[#f]. +} + +@defidform[string]{ +Signatur für Zeichenketten. +} + +@defidform[any]{ +Signatur, die auf alle Werte gültig ist.} + +@defform/none[signature]{ +Signatur für Signaturen.} + +@defidform[property]{ +Signatur für Eigenschaften.} + +@subsection{@racket[predicate]} +@defform[(predicate expr)]{ +Bei dieser Signatur muß @racket[expr] als Wert ein Prädikat haben, also +eine Prozedur, die einen beliebigen Wert akzeptiert und entweder @racket[#t] +oder @racket[#f] zurückgibt. +Die Signatur ist dann für einen Wert gültig, wenn das Prädikat, darauf angewendet, +@racket[#t] ergibt. +} + +@subsection{@racket[one-of]} +@defform[(one-of expr ...)]{ +Diese Signatur ist für einen Wert gültig, wenn er gleich dem Wert eines +der @racket[expr] ist. +} + +@subsection{@racket[mixed]} +@defform[(mixed sig ...)]{ +Diese Signatur ist für einen Wert gültig, wenn er für eine der Signaturen +@racket[sig] gültig ist. +} + +@subsection[#:tag "proc-signature"]{Prozedur-Signatur} +@defidform[->]{ +@defform/none[(sig ... -> sig)]{ +Diese Signatur ist dann für einen Wert gültig, wenn dieser eine +Prozedur ist. Er erklärt außerdem, daß die Signaturen vor dem @racket[->] +für die Argumente der Prozedur gelten und die Signatur nach dem @racket[->] +für den Rückgabewert. +}} +} + +@subsection[#:tag "signature-variable"]{Signatur-Variablen} +@defform/none[%a] +@defform/none[%b] +@defform/none[%c] +@defform/none[...]{ +Dies ist eine Signaturvariable: sie steht für eine Signatur, die für jeden Wert gültig ist. +} + +@subsection{@racket[combined]} +@defform[(combined sig ...)]{ +Diese Signatur ist für einen Wert gültig, wenn sie für alle der Signaturen +@racket[sig] gültig ist. +} + +@section{Testfälle} + +@defform[(check-expect expr expr)]{ + +Dieser Testfall überprüft, ob der erste @racket[expr] den gleichen +Wert hat wie der zweite @racket[expr], wobei das zweite @racket[expr] +meist ein Literal ist.} + +@defform[(check-within expr expr expr)]{ + +Wie @racket[check-expect], aber mit einem weiteren Ausdruck, +der als Wert eine Zahl @racket[_delta] hat. Der Testfall überprüft, daß jede Zahl im Resultat +des ersten @racket[expr] maximal um @racket[_delta] +von der entsprechenden Zahl im zweiten @racket[expr] abweicht.} + +@defform[(check-member-of expr expr ...)]{ + +Ähnlich wie @racket[check-expect]: Der Testfall überprüft, daß das Resultat +des ersten Operanden gleich dem Wert eines der folgenden Operanden ist.} + +@defform[(check-satisfied expr pred)]{ +Ähnlich wie @racket[check-expect]: Der Testfall überprüft, ob der Wert +des Ausdrucks @racket[expr] vom Prädikat @racket[pred] erfüllt wird - +das bedeutet, daß die Prozedur @racket[pred] den Wert @racket[#t] +liefert, wenn sie auf den Wert von @racket[expr] angewendet wird. + +Der folgende Test wird also bestanden: +@racketblock[(check-satisfied 1 odd?)] + +Der folgende Test hingegen wird hingegen nicht bestanden: + +@racketblock[(check-satisfied 1 even?)] +} + +@defform[(check-range expr expr expr)]{ + +Ähnlich wie @racket[check-expect]: Alle drei Operanden müssen +Zahlen sein. Der Testfall überprüft, ob die erste Zahl zwischen der +zweiten und der dritten liegt (inklusive).} + +@defform[(check-error expr expr)]{ + +Dieser Testfall überprüft, ob der erste @racket[expr] einen Fehler produziert, +wobei die Fehlermeldung der Zeichenkette entspricht, die der Wert des zweiten +@racket[expr] ist.} + +@defform[(check-property expr)]{ + +Dieser Testfall überprüft experimentell, ob die @tech{Eigenschaft} +@racket[expr] erfüllt ist. Dazu werden zufällige Werte für die mit +@racket[for-all] quantifizierten Variablen eingesetzt: Damit wird +überprüft, ob die Bedingung gilt. + +@emph{Wichtig:} @racket[check-property] funktioniert nur für +Eigenschaften, bei denen aus den Signaturen sinnvoll Werte generiert +werden können. Dies ist für die meisten eingebauten Signaturen der +Fall, aber nicht für Signaturvariablen und Signaturen, die mit +@scheme[predicate] oder @scheme[define-record-functions] definiert +wurden - wohl aber für Signaturen, die mit dem durch +@scheme[define-record-functions-parametric] definierten +Signaturkonstruktor erzeugt wurden.} + +@section{Pattern-Matching} + +@defform[(match expr (pattern expr) ...) + #:grammar [(pattern + id + #t + #f + string + number + (constructor pattern ...))] + +]{ Ein @racket[match]- Ausdruck führt eine Verzweigung durch, ähnlich +wie @racket[cond]. Dazu wertet match zunächst einmal den Ausdruck +@racket[expr] nach dem match zum Wert @italic{v} aus. Es prüft dann +nacheinander jeden Zweig der Form @racket[(pattern expr)] dahingehend, +ob das Pattern @racket[pattern] darin auf den Wert @italic{v} paßt +(``matcht''). Beim ersten passenden Zweig @racket[(pattern expr)] +macht @racket[match] dann mit der Auswertung voh @racket[expr] weiter. + +Ob ein Wert @italic{v} paßt, hängt von @racket[pattern] ab: + +@itemlist[ +@item{Ein Pattern, das ein Literal ist (@racket[#t], @racket[#f], +Zeichenketten @racket[string], Zahlen @racket[number]) paßt nur dann, +wenn der Wert @italic{v} gleich dem Pattern ist.} + +@item{Ein Pattern, das ein Bezeichner @racket[id] ist, paßt auf +@emph{jeden} Wert. Der Bezeichner wird dann an diesen Wert gebunden +und kann in dem Ausdruck des Zweigs benutzt werden. +} + +@item{Ein Pattern @racket[(constructor pattern ...)], bei dem +@racket[constructor] ein Record-Konstruktor ist (ein +@italic{Konstruktor-Pattern}), paßt auf @italic{v}, falls @italic{v} +ein passender Record ist, und dessen Felder auf die entsprechenden +Patterns passen, die noch im Konstruktor-Pattern stehen.} +] +} + +@; ---------------------------------------------------------------------- + +@; @section{@racket[require]} +@; +@; @defform[(require string)]{ +@; +@; Diese Form macht die Definitionen des durch @racket[string] spezifizierten Moduls +@; verfügbar. Dabei bezieht sich @racket[string] auf eine Datei relativ zu der Datei, +@; in der die @racket[require]-Form steht. +@; +@; Dabei ist @racket[string] leicht eingeschränkt, um Portabilitätsprobleme zu vermeiden: +@; @litchar{/} ist der Separator für Unterverzeichnisse,, @litchar{.} bedeutet das aktuelle +@; Verzeichnis, @litchar{..} meint das übergeordnete Verzeichnis, Pfadelemente +@; können nur @litchar{a} bis @litchar{z} (groß oder klein), +@; @litchar{0} bis @litchar{9}, @litchar{-}, @litchar{_} +@; und @litchar{.} enthalten, und die Zeichenkette kann nicht leer sein oder +@; ein @litchar{/} am Anfang oder Ende enthalten.} +@; +@; +@; @defform/none[#:literals (require) +@; (require module-id)]{ +@; +@; Diese Form macht eine eingebaute Library mit dem Namen @racket[module-id] verfügbar.} +@; +@; @defform/none[#:literals (require lib) +@; (require (lib string string ...))]{ +@; +@; Diese Form macht die Definitionen eines Moduls in einer installierten Bibliothek +@; verfügbar. +@; Der erste +@; @racket[string] ist der Name der Datei des Moduls, und die restlichen +@; @racket[string]s bezeichnen die Collection (und Sub-Collection undsoweiter), +@; in der die Datei installiert ist. Jede @racket[string] ist ebenso eingeschränkt +@; wie bei @racket[(require string)].} +@; +@; +@; @defform/none[#:literals (require planet) +@; (require (planet string (string string number number)))]{ +@; +@; Diese Form macht ein Modul einer Bibliothek verfügbar, die aus PLaneT +@; kommt.} + +@; ---------------------------------------- + +@section{Eigenschaften} + +Eine @deftech{Eigenschaft} definiert eine Aussage über einen +Scheme-Ausdruck, die experimentell überprüft werden kann. Der +einfachste Fall einer Eigenschaft ist ein boolescher Ausdruck. Die +folgende Eigenschaft gilt immer: + +@racketblock[ +(= 1 1) +] + +Es ist auch möglich, in einer Eigenschaft Variablen zu verwenden, für +die verschiedene Werte eingesetzt werden. Dafür müssen die Variablen +gebunden und @deftech{quantifiziert} werden, d.h. es muß festgelegt +werden, welche Signatur die Werte der Variable erfüllen sollen. +Eigenschaften mit Variablen werden mit der @racket[for-all]-Form erzeugt: + +@defform[(for-all ((id sig) ...) expr)]{ +Dies bindet die Variablen @racket[id] in der Eigenschaft +@racket[expr]. Zu jeder Variable gehört eine Signatur +@racket[sig], der von den Werten der Variable erfüllt werden +muß. + +Beispiel: + +@racketblock[ +(for-all ((x integer)) + (= x (/ (* x 2) 2))) +] +} + +@defform[(expect expr expr)]{ + +Ein @racket[expect]-Ausdruck ergibt eine Eigenschaft, die dann gilt, +wenn die Werte von @racket[expr] und @racket[expr] gleich sind, im +gleichen Sinne wie bei @racket[check-expect].} + + +@defform[(expect-within expr expr expr)]{ + +Wie @racket[expect], aber entsprechend @racket[check-within] mit einem +weiteren Ausdruck, der als Wert eine Zahl @racket[_delta] hat. Die +resultierende Eigenschaft gilt, wenn jede Zahl im Resultat des ersten +@racket[expr] maximal um @racket[_delta] von der entsprechenden Zahl +im zweiten @racket[expr] abweicht.} + +@defform[(expect-member-of expr expr ...)]{ + +Wie @racket[expect], aber entsprechend @racket[check-member-of] mit +weiteren Ausdrücken, die mit dem ersten verglichen werden. Die +resultierende Eigenschaft gilt, wenn das erste Argument gleich +einem der anderen Argumente ist.} + +@defform[(expect-range expr expr expr)]{ + +Wie @racket[expect], aber entsprechend @racket[check-range]: Die +Argumente müssen Zahlen sein. Die Eigenschaft gilt, wenn die erste Zahl +zwischen der zweiten und dritten Zahl liegt (inklusive).} + + +@defform[(==> expr expr)]{ +Der erste Operand ist ein boolescher Ausdruck, der zweite Operand eine +Eigenschaft: @racket[(==> c p)] legt fest, daß die Eigenschaft +@racket[p] nur erfüllt sein muß, wenn @racket[c] (die +@emph{Bedingung}) @racket[#t] ergibt, also erfüllt ist.} + +@racketblock[ +(for-all ((x integer)) + (==> (even? x) + (= x (* 2 (/ x 2))))) +] + +@section[#:tag "beginner-prim-ops"]{Primitive Operationen} + +@declare-exporting[deinprogramm/sdp/beginner] +@prim-op-defns['(lib "beginner.rkt" "deinprogramm" "sdp") #'here '()] diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/deinprogramm.scrbl racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/deinprogramm.scrbl --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/deinprogramm.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/deinprogramm.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -3,36 +3,24 @@ @(require scribble/manual (for-label scheme)) -@title[#:style '(toc) #:tag "deinprogramm"]{Sprachebenen und Material zu @italic{Schreibe Dein Programm!} / @italic{Die Macht der Abstraktion}} +@title[#:style '(toc) #:tag "deinprogramm"]{Sprachebenen und Material zu @italic{Schreibe Dein Programm!}} Note: This is documentation for the teachpacks that go with the German -textbooks +textbook @italic{@link["http://www.deinprogramm.de/sdp/"]{Schreibe Dein Programm!}}. -and -@italic{@link["http://www.deinprogramm.de/dmda/"]{Die Macht -der Abstraktion}}. -Das Material in diesem Handbuch ist für die Verwendung mit den Büchern -@italic{@link["http://www.deinprogramm.de/sdp/"]{Schreibe Dein Programm!}}. -und -@italic{@link["http://www.deinprogramm.de/dmda/"]{Die Macht der -Abstraktion}} gedacht. +Das Material in diesem Handbuch ist für die Verwendung mit Buch +@italic{@link["http://www.deinprogramm.de/sdp/"]{Schreibe Dein Programm!}} +gedacht. @table-of-contents[] -@include-section["DMdA-beginner.scrbl"] -@include-section["DMdA-vanilla.scrbl"] -@include-section["DMdA-assignments.scrbl"] -@include-section["DMdA-advanced.scrbl"] +@include-section["beginner.scrbl"] +@include-section["vanilla.scrbl"] +@include-section["advanced.scrbl"] @include-section["ka.scrbl"] -@include-section["image.scrbl"] -@include-section["world.scrbl"] -@include-section["turtle.scrbl"] -@include-section["sound.scrbl"] -@include-section["line3d.scrbl"] - -@include-section["DMdA-lib.scrbl"] +@include-section["sdp-lib.scrbl"] @index-section[] diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/DMdA-advanced.scrbl racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/DMdA-advanced.scrbl --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/DMdA-advanced.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/DMdA-advanced.scrbl 1970-01-01 00:00:00.000000000 +0000 @@ -1,84 +0,0 @@ -#lang scribble/doc -@(require scribblings/htdp-langs/common "std-grammar.rkt" "prim-ops.rkt" - (for-label deinprogramm/DMdA-assignments)) - -@title[#:style 'toc #:tag "DMdA-advanced"]{Die Macht der Abstraktion fortgeschritten} - -This is documentation for the language level @italic{Die Macht der -Abstraktion - fortgeschritten} that goes with the German textbooks -@italic{Schreibe Dein Programm!} / @italic{Die Macht der Abstraktion}. - -@declare-exporting[deinprogramm/DMdA-advanced] - -@racketgrammar*-DMdA[ -#:literals (define-record-procedures-2 set!) -( - (define-record-procedures-2 id id id (field-spec ...)) - (define-record-procedures-parametric-2 id id id id (field-spec ...)) -) -( - [field-spec id (id id)] - [quoted id - number - string - character - symbol - (quoted ...) - @#,elem{@racketvalfont{'}@racket[quoted]}] -) -( - @#,racket[(let ((id expr) (... ...)) expr)] - @#,racket[(letrec ((id expr) (... ...)) expr)] - @#,racket[(let* ((id expr) (... ...)) expr) ] - @#,racket[(begin expr expr (... ...))] - quoted - (set! id expr) - (code:line @#,elem{@racketvalfont{'}@racket[quoted]} (code:comment @#,seclink["advanced-quote"]{Quote-Literal})) -) -( - @#,racket[(list-of sig)] -) -( - @#,racket[(make-pair pattern pattern)] - @#,racket[(list pattern ...)] - @#,elem{@racketvalfont{'}@racket[quoted]} -) -] - -@|prim-nonterms| - -@prim-ops['(lib "DMdA-advanced.rkt" "deinprogramm") #'here] - -@section[#:tag "advanced-quote"]{Quote-Literal} - -@deftogether[( -@defform/none[(unsyntax @elem{@racketvalfont{'}@racket[quoted]})] -@defform[(quote quoted)] -)]{ -Der Wert eines Quote-Literals hat die gleiche externe Repräsentation wie @racket[quoted]. -} - -@section[#:tag "advanced-signatures"]{Signaturen} - -@defidform[symbol]{ -Signatur für Symbole. -} - -@section[#:tag "pattern-matching-advanced"]{Pattern-Matching} - -@defform/none[(match expr (pattern expr) ...) - #:grammar [(pattern - ... - @#,elem{@racketvalfont{'}@racket[quoted]} - )]]{ -Zu den Patterns kommt noch eins hinzu: - -@itemlist[ -@item{Das Pattern @racketvalfont{'}@racket[quoted] paßt auf genau auf Werte, welche -die gleiche externe Repräsentation wie @racket[quoted] haben.} -] -} - -@section[#:tag "advanced-prim-op"]{Primitive Operationen} - -@prim-op-defns['(lib "DMdA-advanced.rkt" "deinprogramm") #'here '()] diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/DMdA-assignments.scrbl racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/DMdA-assignments.scrbl --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/DMdA-assignments.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/DMdA-assignments.scrbl 1970-01-01 00:00:00.000000000 +0000 @@ -1,123 +0,0 @@ -#lang scribble/doc -@(require scribblings/htdp-langs/common "std-grammar.rkt" "prim-ops.rkt" - (for-label deinprogramm/DMdA-assignments - (only-in deinprogramm/DMdA-beginner - define-record-procedures-parametric))) - -@title[#:style 'toc #:tag "DMdA-assignments"]{Die Macht der Abstraktion mit Zuweisungen} - -This is documentation for the language level @italic{Die Macht der -Abstraktion mit Zuweisungen} to go with the German textbooks -@italic{Schreibe Dein Programm!} / @italic{Die Macht der Abstraktion}. - -@declare-exporting[deinprogramm/DMdA-assignments] - -@racketgrammar*-DMdA[ -#:literals (define-record-procedures-2 define-record-procedures-parametric-2 set!) -( - (define-record-procedures-2 id id id (field-spec ...)) - (define-record-procedures-parametric-2 id id id id id (field-spec ...)) -) -( - [field-spec id (id id)] -) -( - @#,racket[(let ((id expr) (... ...)) expr)] - @#,racket[(letrec ((id expr) (... ...)) expr)] - @#,racket[(let* ((id expr) (... ...)) expr) ] - @#,racket[(begin expr expr (... ...))] - (set! id expr) -) -( - @#,racket[(list-of sig)] -) -( - @#,racket[(make-pair pattern pattern)] - @#,racket[(list pattern ...)] -) -] - -@|prim-nonterms| - -@prim-ops['(lib "DMdA-assignments.rkt" "deinprogramm") #'here] - -@section{@racket[define-record-procedures-2]} - -@declare-exporting[deinprogramm/DMdA] - -@defform[(define-record-procedures-2 t c p (field-spec ...))]{ -Die @racket[define-record-procedures-2]-Form ist eine Definition für -einen neuen Record-Typ. Dabei ist @racket[t] der Name der Record-Signatur, -@racket[c] der Name des Konstruktors, @racket[p] der Name des -Prädikats. Jedes @racket[field-spec] kann entweder der Name eines Selektors -oder ein Paar @racket[(id id)] aus dem Namen eines Selektors und dem Namen eines -Mutators sein. -} - -@section{@racket[define-record-procedures-parametric-2]} - -@declare-exporting[deinprogramm/DMdA] - -@defform[(define-record-procedures-parametric-2 t cc c p (field-spec1 ...))]{ -Diese Form ist wie @racket[define-record-procedures-2], nur parametrisch -wie @racket[define-record-procedures-parametric]. Außerdem -werden die Signaturen für die Feldinhalte, anders als bei -@racket[define-record-procedures-parametric], sofort bei der -Konstruktion überprüft und nicht erst beim Aufruf eines Selektors. -} - -@section{@racket[begin]} - -@declare-exporting[deinprogramm/DMdA] - -@defform[(begin expr expr ...)]{ -Bei der Auswertung eines @racket[begin]-Ausdrucks werden nacheinander -die Operanden ausgewertet. Der Wert des letzten Ausdrucks wird der -Wert des @racket[begin]-Ausdrucks. -} - -@section{@racket[set!]} - -@declare-exporting[deinprogramm/DMdA] - -@defform[(set! id expr)]{ -Ein @racket[set!]-Ausdruck ist eine Zuweisung, und ändert den Inhalt -der Zelle, die an @racket[id] gebunden ist, auf den Wert von @racket[expr]. -} - -@section[#:tag "assignments-signatures"]{Signaturen} - -@declare-exporting[deinprogramm/DMdA] - -@defidform[unspecific]{ -Signatur für unspezifische Werte, die unwichtig sind - typischerweise für die -Rückgabewerte von Operationen, die nur Seiteneffekte haben wie @racket[set!] -oder @racket[write-string]. -} - -@section[#:tag "advanced-definitions"]{Definitionen} -@declare-exporting[deinprogramm/DMdA-deflam] - -@defform[(define id expr)]{Diese Form ist wie in den unteren -Sprachebenen, mit dem Unterschied, dass an @racket[id] mit -@racket[set!] zugewiesen werden kann.} - -@section[#:tag "advanced-lambda"]{@racket[lambda] / @racket[λ]} -@declare-exporting[deinprogramm/DMdA-deflam] - -@defform[(lambda (id id ... . id) expr)]{ -Bei @racket[lambda] ist in -dieser Sprachebene in einer Form zulässig, die es erlaubt, eine -Prozedur mit einer variablen Anzahl von Paramern zu erzeugen: Alle -Parameter vor dem Punkt funktionieren wie gewohnt und werden jeweils -an die entsprechenden Argumente gebunden. Alle restlichen Argumente -werden in eine Liste verpackt und an den Parameter nach dem Punkt -gebunden.} - -@defform[(λ (id id ... . id) expr)]{ -@racket[λ] ist ein anderer Name für @racket[lambda]. -} - -@section[#:tag "assignments-prim-op"]{Primitive Operationen} - -@prim-op-defns['(lib "DMdA-assignments.rkt" "deinprogramm") #'here '()] diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/DMdA-beginner.scrbl racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/DMdA-beginner.scrbl --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/DMdA-beginner.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/DMdA-beginner.scrbl 1970-01-01 00:00:00.000000000 +0000 @@ -1,514 +0,0 @@ -#lang scribble/doc -@(require scribblings/htdp-langs/common scribble/struct - "std-grammar.rkt" "prim-ops.rkt" - (for-label deinprogramm/DMdA-beginner)) - -@title[#:style 'toc #:tag "DMdA-beginner"]{Die Macht der Abstraktion - Anfänger} - -This is documentation for the language level @italic{Die Macht der -Abstraktion - Anfänger} to go with the German textbooks -@italic{Schreibe Dein Programm!} / @italic{Die Macht der Abstraktion}. - -@declare-exporting[deinprogramm/DMdA-beginner #:use-sources (deinprogramm/DMdA deinprogramm/define-record-procedures)] - -@racketgrammar*-DMdA[ -#:literals () -() () () () () -] - -@|prim-nonterms| - -@prim-ops['(lib "DMdA-beginner.rkt" "deinprogramm") #'here] - -@; ---------------------------------------------------------------------- - -@section{Definitionen} - -@defform[(define id expr)]{ -Diese Form ist eine Definition, und bindet @racket[id] als -globalen Namen an den Wert von @racket[exp].} - -@section{Record-Typ-Definitionen} - -@defform*[((define-record-procedures t c p (f1 ...)) - (define-record-procedures t c (f1 ...)))]{ - -Die @racket[define-record-procedures]-Form ist eine Definition -für einen neuen Record-Typ. Dabei ist @racket[t] der Name der Record-Signatur, -@racket[c] der Name des Konstruktors und @racket[p] -der (optionale) Name des Prädikats. - -Jedes @racket[f]@subscript{i} beschreibt ein @italic{Feld} des -Record-Typs. Es hat zwei mögliche Formen: - -@itemlist[ - -@item{Das Feld besteht nur aus einem Namen @racket[sel]: Dann ist -@racket[sel] der Name des Selektors für das Feld.} - -@item{Das Feld hat die Form @racket[(sel sig)]: Dann ist @racket[sel] -der Name des Selektors für das Feld und @racket[sig] die Signatur des Feldes.} -] -} - -@section[#:tag "application"]{Prozedurapplikation} - -@defform/none[(expr expr ...)]{ -Dies ist eine Prozeduranwendung oder Applikation. -Alle @racket[expr]s werden ausgewertet: -Der Operator (also der erste Ausdruck) muß eine -Prozedur ergeben, die genauso viele Argumente -akzeptieren kann, wie es Operanden, also weitere @racket[expr]s gibt. -Die Anwendung wird dann ausgewertet, indem der Rumpf -der Applikation ausgewertet wird, nachdem die Parameter -der Prozedur durch die Argumente, also die Werte der -Operanden ersetzt wurden.} - -@; @defform[(#%app id expr expr ...)]{ -@; -@; Eine Prozedurapplikation kann auch mit @racket[#%app] geschrieben -@; werden, aber das macht eigentlich niemand.} - -@section{@racket[#t] and @racket[#f]} - -@as-index{@litchar{#t}} ist das Literal für den booleschen Wert "wahr", -@as-index{@litchar{#f}} das Literal für den booleschen Wert "falsch". - -@section{@racket[lambda] / @racket[λ]} - -@defform[(lambda (id ...) expr)]{ -Ein Lambda-Ausdruck ergibt bei der Auswertung eine neue Prozedur.} - -@defform[(λ (id ...) expr)]{ -@racket[λ] ist ein anderer Name für @racket[lambda]. -} - -@section[#:tag "id"]{Bezeichner} - -@defform/none[id]{ -Eine Variable bezieht sich auf die, von innen nach -außen suchend, nächstgelegene Bindung durch @racket[lambda], @racket[let], @racket[letrec], oder -@racket[let*]. Falls es keine solche lokale Bindung gibt, muß es eine -Definition oder eine eingebaute Bindung mit dem entsprechenden Namen -geben. Die Auswertung des Namens ergibt dann den entsprechenden -Wert. } - -@section{@racket[cond]} - -@defform[(cond (expr expr) ... (expr expr))]{ -Ein @racket[cond]-Ausdruck bildet eine Verzweigung, die aus mehreren -Zweigen besteht. Jeder Zweig besteht -aus einem Test und einem Ausdruck. Bei der Auswertung werden die -Zweige nacheinander abgearbeitet. Dabei wird jeweils zunächst der Test -ausgewertet, der jeweils einen booleschen Wert ergeben müssen. Beim -ersten Test, der @racket[#t] ergibt, wird der Wert des Ausdrucks des Zweigs zum -Wert der gesamten Verzweigung. Wenn kein Test @racket[#t] ergibt, wird das -Programm mit einer Fehlermeldung abgebrochen. -} - -@defform/none[#:literals (cond else) - (cond (expr expr) ... (else expr))]{ - Die Form des @racket[cond]-Ausdrucks ist ähnlich zur vorigen, mit der - Ausnahme, daß in dem Fall, in dem kein Test @racket[#t] ergibt, der Wert des - letzten Ausdruck zum Wert der @racket[cond]-Form wird. -} - -@defidform[else]{ - -Das Schlüsselwort @racket[else] kann nur in @racket[cond] benutzt werden.} - -@; ---------------------------------------------------------------------- - -@section{@racket[if]} - -@defform[(if expr expr expr)]{ -Eine @racket[if]-Form ist eine binäre Verzweigung. Bei der Auswertung wird -zunächst der erste Operand ausgewertet (der Test), der einen -booleschen Wert ergeben muß. Ergibt er @racket[#t], wird der Wert des zweiten -Operanden (die Konsequente) zum Wert der @racket[if]-Form, bei @racket[#f] der Wert des -dritten Operanden (die Alternative). -} - -@; ---------------------------------------------------------------------- - -@section{@racket[and]} - -@defform[(and expr ...)]{ -Bei der Auswertung eines @racket[and]-Ausdrucks werden nacheinander die -Operanden (die boolesche Werte ergeben müssen) ausgewertet. Ergibt -einer @racket[#f], ergibt auch der and-Ausdruck @racket[#f]; wenn alle -Operanden @racket[#t] ergeben, ergibt auch der @racket[and]-Ausdruck -@racket[#t]. -} - -@; ---------------------------------------------------------------------- - -@section{@racket[or]} - -@defform[(or expr ...)]{ -Bei der Auswertung eines @racket[or]-Ausdrucks werden nacheinander die -Operanden (die boolesche Werte ergeben müssen) ausgewertet. Ergibt -einer @racket[#t], ergibt auch der or-Ausdruck @racket[#t]; wenn alle Operanden @racket[#f] -ergeben, ergibt auch der @racket[or]-Ausdruck @racket[#f]. -} - -@section{Signaturen} - -Signaturen können statt der Verträge aus dem Buch geschrieben werden: -Während Verträge reine Kommentare sind, überprüft DrRacket Signaturen -und meldet etwaige Verletzungen. - -@subsection{@racket[signature]} -@defform[(signature sig)]{ -Diese Form liefert die Signatur mit der Notation @racket[sig]. -} - -@subsection{Signaturdeklaration} -@defform[(: id sig)]{ -Diese Form erklärt @racket[sig] zur gültigen Signatur für @racket[id]. -} - -@subsection{Eingebaute Signaturen} - -@defidform[number]{ -Signatur für beliebige Zahlen. -} - -@defidform[real]{ -Signatur für reelle Zahlen. -} - -@defidform[rational]{ -Signatur für rationale Zahlen. -} - -@defidform[integer]{ -Signatur für ganze Zahlen. -} - -@defidform[natural]{ -Signatur für ganze, nichtnegative Zahlen. -} - -@defidform[boolean]{ -Signatur für boolesche Werte. -} - -@defidform[true]{ -Signatur für \scheme[#t]. -} - -@defidform[false]{ -Signatur für \scheme[#f]. -} - -@defidform[string]{ -Signatur für Zeichenketten. -} - -@defidform[empty-list]{ -Signatur für die leere Liste. -} - -@defidform[any]{ -Signatur, die auf alle Werte gültig ist.} - -@defform/none[signature]{ -Signatur für Signaturen.} - -@defidform[property]{ -Signatur für Eigenschaften.} - -@subsection{@racket[predicate]} -@defform[(predicate expr)]{ -Bei dieser Signatur muß @racket[expr] als Wert ein Prädikat haben, also -eine Prozedur, die einen beliebigen Wert akzeptiert und entweder @racket[#t] -oder @racket[#f] zurückgibt. -Die Signatur ist dann für einen Wert gültig, wenn das Prädikat, darauf angewendet, -@racket[#t] ergibt. -} - -@subsection{@racket[one-of]} -@defform[(one-of expr ...)]{ -Diese Signatur ist für einen Wert gültig, wenn er gleich dem Wert eines -der @racket[expr] ist. -} - -@subsection{@racket[mixed]} -@defform[(mixed sig ...)]{ -Diese Signatur ist für einen Wert gültig, wenn er für eine der Signaturen -@racket[sig] gültig ist. -} - -@subsection[#:tag "proc-signature"]{Prozedur-Signatur} -@defidform[->]{ -@defform/none[(sig ... -> sig)]{ -Diese Signatur ist dann für einen Wert gültig, wenn dieser eine -Prozedur ist. Er erklärt außerdem, daß die Signaturen vor dem @racket[->] -für die Argumente der Prozedur gelten und die Signatur nach dem @racket[->] -für den Rückgabewert. -}} -} - -@subsection[#:tag "signature-variable"]{Signatur-Variablen} -@defform/none[%a] -@defform/none[%b] -@defform/none[%c] -@defform/none[...]{ -Dies ist eine Signaturvariable: sie steht für eine Signatur, die für jeden Wert gültig ist. -} - -@subsection{@racket[combined]} -@defform[(combined sig ...)]{ -Diese Signatur ist für einen Wert gültig, wenn sie für alle der Signaturen -@racket[sig] gültig ist. -} - -@section{Testfälle} - -@defform[(check-expect expr expr)]{ - -Dieser Testfall überprüft, ob der erste @racket[expr] den gleichen -Wert hat wie der zweite @racket[expr], wobei das zweite @racket[expr] -meist ein Literal ist.} - -@defform[(check-within expr expr expr)]{ - -Wie @racket[check-expect], aber mit einem weiteren Ausdruck, -der als Wert eine Zahl @racket[_delta] hat. Der Testfall überprüft, daß jede Zahl im Resultat -des ersten @racket[expr] maximal um @racket[_delta] -von der entsprechenden Zahl im zweiten @racket[expr] abweicht.} - -@defform[(check-member-of expr expr ...)]{ - -Ähnlich wie @racket[check-expect]: Der Testfall überprüft, daß das Resultat -des ersten Operanden gleich dem Wert eines der folgenden Operanden ist.} - -@defform[(check-satisfied expr pred)]{ -Ähnlich wie @racket[check-expect]: Der Testfall überprüft, ob der Wert -des Ausdrucks @racket[expr] vom Prädikat @racket[pred] erfüllt wird - -das bedeutet, daß die Prozedur @racket[pred] den Wert @racket[#t] -liefert, wenn sie auf den Wert von @racket[expr] angewendet wird. - -Der folgende Test wird also bestanden: -@racketblock[(check-satisfied 1 odd?)] - -Der folgende Test hingegen wird hingegen nicht bestanden: - -@racketblock[(check-satisfied 1 even?)] -} - -@defform[(check-range expr expr expr)]{ - -Ähnlich wie @racket[check-expect]: Alle drei Operanden müssen -Zahlen sein. Der Testfall überprüft, ob die erste Zahl zwischen der -zweiten und der dritten liegt (inklusive).} - -@defform[(check-error expr expr)]{ - -Dieser Testfall überprüft, ob der erste @racket[expr] einen Fehler produziert, -wobei die Fehlermeldung der Zeichenkette entspricht, die der Wert des zweiten -@racket[expr] ist.} - -@defform[(check-property expr)]{ - -Dieser Testfall überprüft experimentell, ob die @tech{Eigenschaft} -@racket[expr] erfüllt ist. Dazu werden zufällige Werte für die mit -@racket[for-all] quantifizierten Variablen eingesetzt: Damit wird -überprüft, ob die Bedingung gilt. - -@emph{Wichtig:} @racket[check-property] funktioniert nur für -Eigenschaften, bei denen aus den Signaturen sinnvoll Werte generiert -werden können. Dies ist für die meisten eingebauten Signaturen der -Fall, aber nicht für Signaturvariablen und Signaturen, die mit -@scheme[predicate] oder @scheme[define-record-procedures] definiert -wurden - wohl aber für Signaturen, die mit dem durch -@scheme[define-record-procedures-parametric] definierten -Signaturkonstruktor erzeugt wurden.} - -@section{Pattern-Matching} - -@defform[(match expr (pattern expr) ...) - #:grammar [(pattern - id - #t - #f - string - number - (constructor pattern ...))] - -]{ Ein @racket[match]- Ausdruck führt eine Verzweigung durch, ähnlich -wie @racket[cond]. Dazu wertet match zunächst einmal den Ausdruck -@racket[expr] nach dem match zum Wert @italic{v} aus. Es prüft dann -nacheinander jeden Zweig der Form @racket[(pattern expr)] dahingehend, -ob das Pattern @racket[pattern] darin auf den Wert @italic{v} paßt -(``matcht''). Beim ersten passenden Zweig @racket[(pattern expr)] -macht @racket[match] dann mit der Auswertung voh @racket[expr] weiter. - -Ob ein Wert @italic{v} paßt, hängt von @racket[pattern] ab: - -@itemlist[ -@item{Ein Pattern, das ein Literal ist (@racket[#t], @racket[#f], -Zeichenketten @racket[string], Zahlen @racket[number]) paßt nur dann, -wenn der Wert @italic{v} gleich dem Pattern ist.} - -@item{Ein Pattern, das ein Bezeichner @racket[id] ist, paßt auf -@emph{jeden} Wert. Der Bezeichner wird dann an diesen Wert gebunden -und kann in dem Ausdruck des Zweigs benutzt werden. -} - -@item{Ein Pattern @racket[(constructor pattern ...)], bei dem -@racket[constructor] ein Record-Konstruktor ist (ein -@italic{Konstruktor-Pattern}), paßt auf @italic{v}, falls @italic{v} -ein passender Record ist, und dessen Felder auf die entsprechenden -Patterns passen, die noch im Konstruktor-Pattern stehen.} -] -} - -@section{Parametrische Record-Typ-Definitionen} - -@defform[(define-record-procedures-parametric t cc c p (s1 ...))]{ - -Die Form @racket[define-record-procedures-parametric] ist wie -@racket[define-record-procedures]. Zusäzlich wird der Bezeichner -@racket[cc] an einen Signaturkonstruktor gebunden: Dieser akzeptiert -für jedes Feld eine Feld-Signatur und liefert eine Signatur, die nur -Records des Record-Typs @racket[t] erfüllen, bei dem die Feldinhalte -die Feld-Signaturen erfüllen. - -Beispiel: - -@racketblock[ -(define-record-procedures-parametric pare pare-of - make-pare pare? - (pare-one pare-two)) -] - -Dann ist @racket[(pare-of integer string)] die Signatur für -@racket[pare]-Records, bei dem die Feldinhalte die Signaturen -@racket[integer] bzw. @racket[string] erfüllen müssen. - -Die Signaturen für die Feldinhalte werden erst überprüft, wenn ein -Selektor aufgerufen wird. -} - -@; ---------------------------------------------------------------------- - -@; @section{@racket[require]} -@; -@; @defform[(require string)]{ -@; -@; Diese Form macht die Definitionen des durch @racket[string] spezifizierten Moduls -@; verfügbar. Dabei bezieht sich @racket[string] auf eine Datei relativ zu der Datei, -@; in der die @racket[require]-Form steht. -@; -@; Dabei ist @racket[string] leicht eingeschränkt, um Portabilitätsprobleme zu vermeiden: -@; @litchar{/} ist der Separator für Unterverzeichnisse,, @litchar{.} bedeutet das aktuelle -@; Verzeichnis, @litchar{..} meint das übergeordnete Verzeichnis, Pfadelemente -@; können nur @litchar{a} bis @litchar{z} (groß oder klein), -@; @litchar{0} bis @litchar{9}, @litchar{-}, @litchar{_} -@; und @litchar{.} enthalten, und die Zeichenkette kann nicht leer sein oder -@; ein @litchar{/} am Anfang oder Ende enthalten.} -@; -@; -@; @defform/none[#:literals (require) -@; (require module-id)]{ -@; -@; Diese Form macht eine eingebaute Library mit dem Namen @racket[module-id] verfügbar.} -@; -@; @defform/none[#:literals (require lib) -@; (require (lib string string ...))]{ -@; -@; Diese Form macht die Definitionen eines Moduls in einer installierten Bibliothek -@; verfügbar. -@; Der erste -@; @racket[string] ist der Name der Datei des Moduls, und die restlichen -@; @racket[string]s bezeichnen die Collection (und Sub-Collection undsoweiter), -@; in der die Datei installiert ist. Jede @racket[string] ist ebenso eingeschränkt -@; wie bei @racket[(require string)].} -@; -@; -@; @defform/none[#:literals (require planet) -@; (require (planet string (string string number number)))]{ -@; -@; Diese Form macht ein Modul einer Bibliothek verfügbar, die aus PLaneT -@; kommt.} - -@; ---------------------------------------- - -@section{Eigenschaften} - -Eine @deftech{Eigenschaft} definiert eine Aussage über einen -Scheme-Ausdruck, die experimentell überprüft werden kann. Der -einfachste Fall einer Eigenschaft ist ein boolescher Ausdruck. Die -folgende Eigenschaft gilt immer: - -@racketblock[ -(= 1 1) -] - -Es ist auch möglich, in einer Eigenschaft Variablen zu verwenden, für -die verschiedene Werte eingesetzt werden. Dafür müssen die Variablen -gebunden und @deftech{quantifiziert} werden, d.h. es muß festgelegt -werden, welche Signatur die Werte der Variable erfüllen sollen. -Eigenschaften mit Variablen werden mit der @racket[for-all]-Form erzeugt: - -@defform[(for-all ((id sig) ...) expr)]{ -Dies bindet die Variablen @racket[id] in der Eigenschaft -@racket[expr]. Zu jeder Variable gehört eine Signatur -@racket[sig], der von den Werten der Variable erfüllt werden -muß. - -Beispiel: - -@racketblock[ -(for-all ((x integer)) - (= x (/ (* x 2) 2))) -] -} - -@defform[(expect expr expr)]{ - -Ein @racket[expect]-Ausdruck ergibt eine Eigenschaft, die dann gilt, -wenn die Werte von @racket[expr] und @racket[expr] gleich sind, im -gleichen Sinne wie bei @racket[check-expect].} - - -@defform[(expect-within expr expr expr)]{ - -Wie @racket[expect], aber entsprechend @racket[check-within] mit einem -weiteren Ausdruck, der als Wert eine Zahl @racket[_delta] hat. Die -resultierende Eigenschaft gilt, wenn jede Zahl im Resultat des ersten -@racket[expr] maximal um @racket[_delta] von der entsprechenden Zahl -im zweiten @racket[expr] abweicht.} - -@defform[(expect-member-of expr expr ...)]{ - -Wie @racket[expect], aber entsprechend @racket[check-member-of] mit -weiteren Ausdrücken, die mit dem ersten verglichen werden. Die -resultierende Eigenschaft gilt, wenn das erste Argument gleich -einem der anderen Argumente ist.} - -@defform[(expect-range expr expr expr)]{ - -Wie @racket[expect], aber entsprechend @racket[check-range]: Die -Argumente müssen Zahlen sein. Die Eigenschaft gilt, wenn die erste Zahl -zwischen der zweiten und dritten Zahl liegt (inklusive).} - - -@defform[(==> expr expr)]{ -Der erste Operand ist ein boolescher Ausdruck, der zweite Operand eine -Eigenschaft: @racket[(==> c p)] legt fest, daß die Eigenschaft -@racket[p] nur erfüllt sein muß, wenn @racket[c] (die -@emph{Bedingung}) @racket[#t] ergibt, also erfüllt ist.} - -@racketblock[ -(for-all ((x integer)) - (==> (even? x) - (= x (* 2 (/ x 2))))) -] - -@section[#:tag "beginner-prim-ops"]{Primitive Operationen} - -@declare-exporting[deinprogramm/DMdA-beginner] -@prim-op-defns['(lib "DMdA-beginner.rkt" "deinprogramm") #'here '()] diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/DMdA-lib.scrbl racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/DMdA-lib.scrbl --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/DMdA-lib.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/DMdA-lib.scrbl 1970-01-01 00:00:00.000000000 +0000 @@ -1,53 +0,0 @@ -#lang scribble/doc -@(require scribble/manual - scribble/eval - (for-label scheme/base - scheme/contract - scheme/class - scheme/gui/base - lang/posn - lang/imageeq - lang/prim)) - -@(define DMdA @italic{Die Macht der Abstraktion}) -@(define (DMdA-ref s) @secref[#:doc '(lib "deinprogramm/scribblings/deinprogramm.scrbl") s]) - -Note: This is documentation for the language levels that go with the -German textbook @italic{@link["http://www.deinprogramm.de/dmda/"]{Die -Macht der Abstraktion}}. - -@title{@bold{DMdA}: Sprachen als Libraries} - -@; ------------------------------------------------------------ -@section{@italic{Die Macht der Abstraktion} - Anfänger} - -@defmodule[deinprogramm/DMdA-beginner] - -Das Modul @racketmodname[deinprogramm/DMdA-beginner] implementiert die -Anfängersprache für @|DMdA|; siehe @DMdA-ref["DMdA-beginner"]. - -@; ------------------------------------------------------------ -@section{@italic{Die Macht der Abstraktion}} - -@defmodule[deinprogramm/DMdA-vanilla] - -Das Modul @racketmodname[deinprogramm/DMdA-vanilla] implementiert die -Standardsprache für @|DMdA|; siehe @DMdA-ref["DMdA-vanilla"]. - -@; ------------------------------------------------------------ -@section{@italic{Die Macht der Abstraktion} mit Zuweisungen} - -@defmodule[deinprogramm/DMdA-assignments] - -Das Modul @racketmodname[deinprogramm/DMdA-assignments] implementiert -die Sprachebene für @|DMdA| mit Zuweisungen und Mutationen; siehe -@DMdA-ref["DMdA-assignments"]. - -@; ------------------------------------------------------------ -@section{@italic{Die Macht der Abstraktion} - fortgeschritten} - -@defmodule[deinprogramm/DMdA-advanced] - -Das Modul @racketmodname[deinprogramm/DMdA-advanced] implementiert -die fortgeschrittene Sprachebene für @|DMdA|; siehe -@DMdA-ref["DMdA-advanced"]. diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/DMdA-vanilla.scrbl racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/DMdA-vanilla.scrbl --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/DMdA-vanilla.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/DMdA-vanilla.scrbl 1970-01-01 00:00:00.000000000 +0000 @@ -1,117 +0,0 @@ -#lang scribble/doc -@(require scribblings/htdp-langs/common "std-grammar.rkt" "prim-ops.rkt" - (for-label deinprogramm/DMdA-vanilla - (only-in deinprogramm/DMdA-beginner define))) - -@title[#:style 'toc #:tag "DMdA-vanilla"]{Die Macht der Abstraktion} - -This is documentation for the language level @italic{Die Macht der -Abstraktion} to go with the German textbooks -@italic{Schreibe Dein Programm!} / @italic{Die Macht der Abstraktion}. - -@declare-exporting[deinprogramm/DMdA-vanilla #:use-sources (deinprogramm/DMdA)] - -@racketgrammar*-DMdA[ -#:literals () -() () -( - @#,racket[(let ((id expr) (... ...)) expr)] - @#,racket[(letrec ((id expr) (... ...)) expr)] - @#,racket[(let* ((id expr) (... ...)) expr) ] -) -( - @#,racket[(list-of sig)] -) -( - @#,racket[empty] - @#,racket[(make-pair pattern pattern)] - @#,racket[(list pattern ...)] -) -] - -@|prim-nonterms| - -@prim-ops['(lib "DMdA-vanilla.rkt" "deinprogramm") #'here] - -@section[#:tag "signatures-vanilla"]{Signaturen} - -@subsection{@racket[list-of]} - -@defform[(list-of sig)]{ -Diese Signatur ist dann für einen Wert gültig, wenn dieser eine Liste ist, -für dessen Elemente @racket[sig] gültig ist. -} - -@section{@racket[let], @racket[letrec] und @racket[let*]} - -@defform[(let ((id expr) ...) expr)]{ - -Bei einem @racket[let]-Ausdruck werden zunächst die @racket[expr]s aus -den @racket[(id expr)]-Paaren ausgewertet. Ihre Werte werden dann im -Rumpf-@racket[expr] für die Namen @racket[id] eingesetzt. Dabei können -sich die Ausdrücke nicht auf die Namen beziehen. - -@racketblock[ -(define a 3) -(let ((a 16) - (b a)) - (+ b a)) -=> 19] - -Das Vorkommen von @racket[a] in der Bindung von @racket[b] bezieht -sich also auf das @racket[a] aus der Definition, nicht das @racket[a] -aus dem @racket[let]-Ausdruck. -} - -@defform[(letrec ((id expr) ...) expr)]{ -Ein @racket[letrec]-Ausdruck ist -ähnlich zum entsprechenden @racket[let]-Ausdruck, mit dem Unterschied, daß sich -die @racket[expr]s aus den Bindungen auf die gebundenen Namen beziehen -dürfen.} - -@defform[(let* ((id expr) ...) expr)]{ -Ein @racket[let*]-Ausdruck ist ähnlich zum entsprechenden -@racket[let]-Ausdruck, mit dem Unterschied, daß sich die @racket[expr]s -aus den Bindungen auf die Namen beziehen dürfen, die jeweils vor dem -@racket[expr] gebunden wurden. Beispiel: - -@racketblock[ -(define a 3) -(let* ((a 16) - (b a)) - (+ b a)) -=> 32] - -Das Vorkommen von @racket[a] in der Bindung von @racket[b] bezieht -sich also auf das @racket[a] aus dem @racket[let*]-Ausdruck, nicht das -@racket[a] aus der globalen Definition. -} - -@section[#:tag "pattern-matching-vanilla"]{Pattern-Matching} - -@defform/none[(match expr (pattern expr) ...) - #:grammar [(pattern - ... - empty - (make-pair pattern pattern) - (list pattern ...) - )]]{ -Zu den Patterns aus der "Anfänger"-Sprache kommen noch drei neue hinzu: - -@itemlist[ -@item{Das Pattern @racket[empty] paßt auf die leere Liste.} - -@item{Das Pattern @racket[(make-pair pattern pattern)] paßt auf Paare, bei - denen die beiden inneren Patterns auf @racket[first] bzw. @racket[rest] passen.} - -@item{Das Pattern [(list pattern ...)] paßt auf Listen, die genauso -viele Elemente haben, wie Teil-Patterns im @racket[list]-Pattern -stehen und bei denen die inneren Patterns auf die Listenelemente -passen. -} -] -} - -@section[#:tag "vanilla-prim-op"]{Primitive Operationen} - -@prim-op-defns['(lib "DMdA-vanilla.rkt" "deinprogramm") #'here '()] diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/image.scrbl racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/image.scrbl --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/image.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/image.scrbl 1970-01-01 00:00:00.000000000 +0000 @@ -1,250 +0,0 @@ -#lang scribble/doc - -@(require scribble/manual "shared.rkt" - (for-label scheme teachpack/deinprogramm/image)) - -@teachpack["image"]{Bilder konstruieren} - -Note: This is documentation for the @filepath{image.rkt} teachpack that goes -with the German textbook -@italic{@link["http://www.deinprogramm.de/dmda/"]{Die Macht der -Abstraktion}}. - -@declare-exporting[teachpack/deinprogramm/image #:use-sources (deinprogramm/image)] - -Dieses Teachpack definiert Prozeduren für die Konstruktion von Bildern. -Einfache Bilder werden als geometrische Formen oder Bitmaps konstruiert. -Zusätzliche Prozeduren erlauben die Komposition von Bildern. - -@;----------------------------------------------------------------------------- -@section{Bilder} - -@defthing[image signature]{ -Ein @deftech{Bild} (Name: @racket[image]) ist die Repräsentation eines Bildes. -} - -@defthing[empty-image image]{ -Ein leeres Bild mit Breite und Höhe 0. -} - -@defthing[image? (any -> boolean?)]{Der Aufruf @racket[(image? x)] stellt fest, ob @racket[x] ein Bild ist.} - -@;----------------------------------------------------------------------------- -@section[#:tag "modes-colors"]{Modi und Farben} - -@defthing[mode signature]{ -@racket[(one-of "solid" "outline")] - -Ein Modus (Name: @racket[mode]) legt fest, ob die Darstellung einer Form diese füllt -oder nur einen Umriss zeichnet.} - -@defthing[octet signature]{ -@racket[(combined natural (predicate (lambda (n) (<= n 255))))] - -Ein Oktet (Name: @racket[octet]) ist eine natürliche Zahl zwischen 0 und 255.} - -@defthing[rgb-color signature]{ -Eine @deftech{RGB-Farbe} ist eine Farbe (Name: @racket[color], die vom -Record-Konstruktor @racket[make-color] zurückgegeben wird: -} - -@defthing[make-color (octet octet octet -> rgb-color)]{ -Eine @tech{RGB-Farbe} beschreibt eine Farbe mit den roten, blauen und grünen Anteilen, -also z.B. @racket[(make-color 100 200 30)].} - -@defthing[color-red (color -> octet)]{ - liefert den Rot-Anteil einer RGB-Farbe.} -@defthing[color-green (color -> octet)]{ - liefert den Grün-Anteil einer RGB-Farbe.} -@defthing[color-blue (color -> octet)]{ - liefert den Blau-Anteil einer RGB-Farbe.} - -@defthing[color? (any -> boolean)]{ -stellt fest, ob ein Objekt eine @tech{RGB-Farbe} ist.} - -@defthing[image-color signature]{ -@racket[(mixed string rgb-color)] - -Eine @deftech{Farbe} (Name: @racket[image-color]) ist eine Zeichenkette aus einer Farbbezeichnung -(z.B. @racket["blue"]) oder eine @tech{RGB-Farbe}.} - -@defthing[image-color? (any -> boolean?)]{ stellt fest, ob ein Objekt -eine @tech{Farbe} ist.} - -@defthing[alpha-rgb-color signature]{ -Eine @deftech{Alpha/RGB-Farbe} ist eine Farbe (Name: @racket[color], die vom -Record-Konstruktor @racket[make-alpha-color] zurückgegeben wird: -} - -@defthing[make-alpha-color (octet octet octet octet -> alpha-color)]{ -Eine @tech{Alpha/RGB-Farbe} beschreibt eine Farbe mit den Alpha-, roten, -blaue und grünen Anteilen, also z.B. @racket[(make-color 50 100 200 -30)]. Der Alpha-Anteil beschreibt, wie durchsichtig die Farbe ist.} - -@defthing[alpha-color-red (color -> octet)]{ - liefert den Rot-Anteil einer RGB-Farbe.} -@defthing[alpha-color-green (color -> octet)]{ - liefert den Grün-Anteil einer RGB-Farbe.} -@defthing[alpha-color-blue (color -> octet)]{ - liefert den Blau-Anteil einer RGB-Farbe.} -@defthing[alpha-color-alpha (color -> octet)]{ - liefert den Alpha-Anteil einer RGB-Farbe.} - -@defthing[alpha-color? (any -> boolean)]{ -stellt fest, ob ein Objekt eine @tech{Alpha/RGB-Farbe} ist.} - - - -@;----------------------------------------------------------------------------- -@section[#:tag "creational"]{Einfache geometrische Figuren} - -Die folgenden Prozeduren erzeugen Bilder mit einfachen geometrischen Formen: - -@defthing[rectangle (natural natural mode image-color -> image)]{ - Der Aufruf @racket[(rectangle w h m c)] - erzeugt ein Rechteck mit Breite @racket[w] und Höhe @racket[h], gefüllt mit Modus - @racket[m] und in Farbe @racket[c].} - -@defthing[circle (natural mode image-color -> image)]{ - Der Aufruf @racket[(circle r m c)] - erzeugt einen Kreis oder eine Scheibe mit Radius @racket[r], gefüllt mit Modus - @racket[m] und in Farbe @racket[c].} - -@defthing[ellipse (natural natural mode image-color -> image)]{ - Der Aufruf @racket[(ellipse w h m c)] - erzeugt eine Ellipse mit Breite @racket[w] und Höhe @racket[h], gefüllt mit Modus - @racket[m] und in Farbe @racket[c].} - -@defthing[triangle (integer mode image-color -> image)]{ - Der Aufruf @racket[(triangle s m c)] - erzeugt ein nach oben zeigendes gleichseitiges Dreieck, wobei - @racket[s] die Seitenlänge angibt, gefüllt mit Modus - @racket[m] und in Farbe @racket[c].} - -@defthing[line (natural natural number number number number image-color -> image)]{ - Der Aufruf @racket[(line w h sx sy ex ey c)] - erzeugt ein Bild mit einer farbigen Strecke, wobei @racket[w] die Breite und @racket[h] die Höhe des Bilds, - sowie @racket[sx] die X- und @racket[sx] die Y-Koordinate des Anfangspunkts und - @racket[ex] die X- und @racket[ey] die Y-Koordinate des Endpunkts angeben, gefüllt mit Modus - @racket[m] und in Farbe @racket[c].} - -@defthing[text (string natural image-color -> image)]{ - Der Aufruf @racket[(text s f c)] - erzeugt ein Bild mit Text @racket[s], - wobei die Buchstaben die Größe @racket[f] haben, in Farbe @racket[c]} - -Außerdem können beliebige Bitmap-Bilder in ein Scheme-Programm -eingeklebt werden. - -@;----------------------------------------------------------------------------- -@section[#:tag "properties"]{Eigenschaften von Bildern} - -Zwei Eigenschaften von Bildern sind für ihre Manipulation nützlich, -nämlich Breite und Höhe: - -@defthing[image-width (image -> natural)]{ - liefert die Breite von @racket[i] in Pixeln.} - -@defthing[image-height (image -> natural)]{ - liefert die Höhe von @racket[i] in Pixeln.} - -@defthing[image-inside? (image image -> boolean)]{ -Der Aufruf @racket[(image-inside? i1 i2)] stellt fest, ob das Bild -@racket[i2] im Bild @racket[i1] enthalten ist.} - -@defthing[find-image (image image -> posn)]{ -Der Aufruf @racket[(find-image i1 i2)] findet die Position von @racket[i2] -im Bild @racket[i1] (in dem es vorkommen muss).} - -@;----------------------------------------------------------------------------- -@section[#:tag "composition"]{Bilder zusammensetzen} - -The nächste Gruppe von Prozeduren baut aus Bildern neue Bilder: - -@defthing[h-place signature]{ -@racket[(mixed integer (one-of "left" "right" "center"))] - -Eine @deftech{horizontale Positionsangabe} (Name: @racket[h-place]) -gibt an, wie zwei Bilder horizontal zueinander positioniert werden - -Im ersten Fall, wenn es sich um eine Zahl @racket[x] handelt, wird das -zweite Bild @racket[x] Pixel vom linken Rand auf das erste gelegt. -Die drei Fälle mit Zeichenketten sagen, daß die Bilder am linken Rand -bzw. am rechten Rand bündig plaziert werden, bzw. das zweite Bild -horizontal in die Mitte des ersten gesetzt wird.} - -@defthing[v-place signature]{ -@racket[(mixed integer (one-of "top" "bottom" "center"))] - -Eine @deftech{vertikale Positionsangabe} (Name: @racket[v-place]) -gibt an, wie zwei Bilder vertikal zueinander positioniert werden - -Im ersten Fall, wenn es sich um eine Zahl @racket[y] handelt, wird das -zweite Bild @racket[y] Pixel vom oberen Rand auf das erste gelegt. -Die drei Fälle mit Zeichenketten sagen, daß die Bilder am oberen Rand -bzw. am unteren Rand bündig plaziert werden, bzw. das zweite Bild -vertikal in die Mitte des ersten gesetzt wird. -} - -@defthing[h-mode signature]{ -@racket[(one-of "left" "right" "center")] -Eine @deftech{horizontale Justierungsangabe} (Name: @racket[h-mode]) -gibt an, ob zwei Bilder, die übereinander angeordnet werden, entlang der linken -Kante, der rechten Kante oder der Mitte angeordnet werden. -} - -@defthing[v-mode signature]{ -@racket[(one-of "top" "bottom" "center")] - -Eine @deftech{vertikale Justierungsangabe} (Name: @racket[V-mode]) -gibt an, ob zwei Bilder, die nebenander angeordnet werden, entlang der -oberen Kante, der untern Kante oder der Mitte angeordnet werden.} - -@defthing[overlay (image image h-place v-place -> image)]{ - Der Aufruf @racket[(overlay img other h v)] - legt zweite Bild @racket[other] auf das erste @racket[img]. Die beiden anderen Argumente geben an, wie - die beiden Bilder zueinander positioniert werden.} - -@defthing[beside (image image v-mode -> image)]{ - Der Aufruf @racket[(beside img other v)] - ordnet die beiden Bilder entsprechend des @racket[v]-Arguments - nebeneinander an.} - -@defthing[above (image image h-mode -> image)]{ - Der Aufruf @racket[(img other h -> image)] - ordnet die beiden Bilder entsprechend des @racket[h]-Arguments - übereinander an.} - -@defthing[clip (image natural natural natural natural -> image)]{ - Der Aufruf @racket[(clip img x y w h)] - liefert das Teilrechteck des Bildes @racket[img] - bei (@racket[x], @racket[y]), Breite @racket[w] und Höhe @racket[h].} - -@defthing[pad (image natural natural natural natural -> image)]{ - Der Aufruf @racket[(pad img l r t b)] - fügt an den Seiten von @racket[img] noch transparenten Leerraum an: - @racket[l] Pixel links, @racket[r] Pixel rechts, @racket[t] Pixel oben und - @racket[b] Pixel unten.} - - -@;----------------------------------------------------------------------------- -@section[#:tag "from-pixels"]{Bilder aus Pixeln konstruieren} - -@defthing[color-list->image ((list-of color) natural natural -> image)]{ - Der Aufruf @racket[(color-list->image lis w h)] stellt ein Bild mit - Breite @racket[w] und Höhe @racket[h] her, in dem die Pixel die - Farben aus der Liste @racket[lis] (welche die Länge @racket[(* w h)] - haben muß) haben.} - -@defthing[image->color-list (image -> (list-of rgb-color))]{ - Diese Prozedur liefert eine Liste der RGB-Farben der Pixel eines Bildes.} - -@defthing[alpha-color-list->image ((list-of alpha-rgb-color) natural natural -> image)]{ - Der Aufruf @racket[(color-list->image lis w h)] stellt ein Bild mit - Breite @racket[w] und Höhe @racket[h] her, in dem die Pixel die - Farben aus der Liste @racket[lis] (welche die Länge @racket[(* w h)] - haben muß) haben.} - -@defthing[image->alpha-color-list (image -> (list-of rgb-color))]{ - Diese Prozedur liefert eine Liste der Alpha/RGB-Farben der Pixel - eines Bildes.} diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/ka.scrbl racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/ka.scrbl --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/ka.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/ka.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -8,8 +8,8 @@ @title{Konstruktionsanleitungen 1 bis 10} -This documents the design recipes of the German textbook @italic{Die -Macht der Abstraktion}. +This documents the design recipes of the German textbook @italic{Schreibe +Dein Programm!}. @table-of-contents[] @@ -83,9 +83,11 @@ Prädikat @racket[pred?] und die Selektoren @elem[@racket[select] @subscript{i}] wählen: @racketblock[ -(define-record-procedures sig +(define-record-functions sig constr pred? - (#,(elem @racket[select] @subscript{1}) ... #,(elem @racket[select] @subscript{n}))) + (#,(elem @racket[select] @subscript{1}) #,(elem @racket[sig] @subscript{n})) + ... + (#,(elem @racket[select] @subscript{n}) #,(elem @racket[sig] @subscript{n}))) ] Schreiben Sie außerdem eine Signatur für den Konstruktor der @@ -327,30 +329,3 @@ (!-helper (- n 1) (* n acc))))) ] -@section{gekapselter Zustand} -Falls ein Wert Zustand enthalten soll, schreiben Sie eine -Datendefinition wie bei zusammengesetzten Daten. - -Schreiben Sie dann eine Record-Definition mit -@racket[define-record-procedures-2] und legen Sie dabei fest, welche -Bestandteile veränderbar sein sollen. Geben Sie Mutatoren für die -betroffenen Felder an. Wenn der Selektor für das Feld @racket[select] -heißt, sollte der Mutator i.d.R. @racket[set-select!] heißen. Die Form -sieht folgendermaßen aus, wobei an der Stelle @racket[k] ein -veränderbares Feld steht: - -@racketblock[ -(define-record-procedures-2 sig - constr pred? - (#,(elem @racket[select] @subscript{1}) ... (#,(elem @racket[s] @subscript{k}) #,(elem @racket[mutate] @subscript{k})) ... #,(elem @racket[s] @subscript{n}))) -] - -In der Schablone für Prozeduren, die den Zustand eines Record-Arguments -@racket[r] ändern, benutzen Sie den dazugehörigen Mutator -@elem[@racket[mutate] @subscript{k}] Wenn @racket[a] der Ausdruck für -den neuen Wert der Komponente ist, sieht der Aufruf folgendermaßen aus: -@racket[(#,(elem @racket[mutate] @subscript{k}) r a)]. - -Um mehrere Komponenten in einer Prozedur zu verändern, oder um einen -sinnvollen Rückgabewert nach einer Mutation zu liefern, benutzen Sie -@racket[begin]. diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/line3d.scrbl racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/line3d.scrbl --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/line3d.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/line3d.scrbl 1970-01-01 00:00:00.000000000 +0000 @@ -1,240 +0,0 @@ -#lang scribble/doc - -@(require scribble/manual "shared.rkt" - (for-label scheme - teachpack/deinprogramm/image - teachpack/deinprogramm/line3d)) - -@teachpack["line3d"]{3D-Liniengraphik} - -Note: This is documentation for the @filepath{line3d.rkt} teachpack that goes -with the German textbook -@italic{@link["http://www.deinprogramm.de/dmda/"]{Die Macht der -Abstraktion}}. - -@declare-exporting[teachpack/deinprogramm/line3d #:use-sources (teachpack/deinprogramm/line3d)] - -Dieses teachpack definiert Prozeduren für lineare Algebra und 3D-Rendering: - -@;---------------------------------------------------------------------------------- -@section[#:tag "rendering"]{Szenen erzeugen} - -@declare-exporting[teachpack/deinprogramm/line3d] - -@defthing[render-scene (natural natural (list-of line3d) matrix4x4 -> image)]{ - Der Aufruf @racket[(render-scene width height scene camera-matrix)]erzeugt die Szene - in ein Bild mit Breite @racket[width] und Höhe @racket[height]. Position, - Orientierung und Projektion werden durch die @racket[camera-matrix] festgelegt. -} - -@defthing[create-camera-matrix (vec3 vec3 number natural natural -> matrix4x4)]{ - Der Aufruf @racket[(create-camera-matrix position lookat vertical-fov width height)] - erzeugt eine 4x4 Matrix. Diese kodiert eine Kamera an der Position @racket[position], die - auf die Position @racket[lookat] schaut. - @racket[vertical-fov] bezeichnet das @deftech{vertikale Feld} der Szene. -} - -Zum Beispiel: - -@racketblock[ -(code:comment @#,t{scene-data (simple box example)}) -(define box - (create-box 1.0 1.0 1.0 "brown")) -(code:comment @#,t{screen}) -(define screenWidth 320) -(define screenHeight 240) -(code:comment @#,t{camera}) -(define pos (make-vec3 5 5 3)) -(define lookat (make-vec3 0 0 0)) -(define camera - (create-camera-matrix pos lookat 70.0 screenWidth screenHeight)) -(code:comment @#,t{render image}) -(render-scene screenWidth screenHeight box camera) -] - -@;------------------------------------------------------------------------------------- -@section[#:tag "3Dvectors"]{3D-Vektoren} - -@defthing[vec3 signature]{ - Ein @deftech{3D-Vektor} (Name: @racket[vec3]) ist ein Record, der durch den Aufruf @racket[make-vec3] erstellt wird. -} - -@defthing[make-vec3 (number number number -> vec3)]{ - @racket[(make-vec3 x y z)] erstellt einen Vektor (x,y,z). -} - -@defthing[add-vec3 (vec3 vec3 -> vec3)]{ - @racket[(add-vec3 a b)] gibt die Summe von @racket[a] und @racket[b] zurück. -} - -@defthing[sub-vec3 (vec3 vec3 -> vec3)]{ - @racket[(sub-vec3 a b)] gibt die Differenz zwischen @racket[a] und @racket[b] zurück. -} - -@defthing[mult-vec3 (vec3 number -> vec3)]{ - @racket[(mult-vec3 a s)] gibt den das Produkt von @racket[a] und @racket[s] zurück. -} - -@defthing[div-vec3 (vec3 number -> vec3)]{ - @racket[(div-vec3 a s)] gibt den das Produkt von @racket[a] und dem Kehrwert von @racket[s] zurück. -} - -@defthing[dotproduct-vec3 (vec3 vec3 -> number)]{ - @racket[(dotproduct-vec3 a b)] gibt das Produkt von @racket[a] und @racket[b] zurück. -} - -@defthing[normQuad-vec3 (vec3 -> number)]{ - @racket[(normQuad-vec3 a)] gibt die quadrierte Norm/Länge |@racket[a]|² eines Vektors @racket[a] zurück (Quadrat der Euklidischen Norm.) -} - -@defthing[norm-vec3 (vec3 -> number)]{ - @racket[(norm-vec3 a)] gibt die Norm/Länge |@racket[a]| eines Vektors a zurück (Euklidische Norm.) -} - -@defthing[normalize-vec3 (vec3 -> vec3)]{ - @racket[(normalize-vec3 a)] normalisiert @racket[a]. -} - -@defthing[crossproduct-vec3 (vec3 vec3-> vec3)]{ - @racket[(crossproduct-vec3 a b)] gibt das Kreuzprodukt von @racket[a] -und @racket[b] zurück (einen Vektor der senkrecht auf @racket[a] und @racket[b] steht). -} - -@;------------------------------------------------------------------------------------- -@section[#:tag "4Dvectors"]{4D-Vektoren} - -@defthing[vec4 signature]{ - Ein @deftech{4D-Vektor} @racket[vec4] ist ein 4D-Vektor. Folgende Prozeduren werden bereitgestellt: -} - -@defthing[make-vec4 (number number number number -> vec4)]{ - @racket[(make-vec4 a b c d)] erzeugt einen Vektor aus @racket[a], @racket[b], @racket[c] und @racket[d]. -} - -@defthing[add-vec4 (vec4 vec4 -> vec4)]{ -@racket[(add-vec4 a b)] gibt die Summe von @racket[a] und @racket[b] zurück. -} - -@defthing[sub-vec4 (vec4 vec4 -> vec4)]{ - @racket[(sub-vec4 a b)] gibt die Differenz zwischen @racket[a] und @racket[b] zurück. -} - -@defthing[mult-vec4 (vec4 number -> vec4)]{ - @racket[(mult-vec4 a s)] gibt den das Produkt von @racket[a] und @racket[s] zurück. -} - -@defthing[div-vec4 (vec4 number -> vec4)]{ - @racket[(div-vec4 a s)] gibt den das Produkt von @racket[a] und dem Kehrwert von @racket[s] zurück. -} - -@defthing[dotproduct-vec4 (vec3 vec4 -> number)]{ - @racket[(dotproduct-vec4 a b)] gibt die quadrierte Norm/Länge |@racket[a]|² eines Vektors @racket[a] zurück (Quadrat der Euklidischen Norm.) -} - -@defthing[normQuad-vec4 (vec4 -> number)]{ - @racket[(normQuad-vec4 a)] gibt die quadrierte Norm/Länge |@racket[a]|² eines Vektors @racket[a] zurück (Quadrat der Euklidischen Norm.) -} - -@defthing[norm-vec4 (vec4 -> number)]{ - @racket[(norm-vec4 a)] gibt die Norm/Länge |a| eines Vektors a zurück (Euklidische Norm) -} - -@defthing[normalize-vec4 (vec4 -> vec4)]{ - @racket[(normalize-vec4 a)] normalisiert @racket[a]. -} - -@defthing[expand-vec3 (vec3 number -> vec4)]{ - @racket[(expand-vec3 a s)] gibt den 4D-Vektor mit @racket[s] als letze Komponente zurück (erweitert @racket[a] mit @racket[s]). -} - -@;------------------------------------------------------------------------------------- -@section[#:tag "4x4matrix"]{4x4 Matrizen} - -@defthing[matrix4x4 signature]{ - Eine @deftech{Matrix} @racket[matrix4x4] ist ein Record, der durch den Aufruf @racket[make-matrix4x4] erstellt wird. -} - -@defthing[make-matrix4x4 (vec4 vec4 vec4 vec4 -> matrix4x4)]{ - @racket[(make-matrix4x4 a b c d)] erstellt eine Matrix aus @racket[a], @racket[b], @racket[c] und @racket[d]. -} - -@defthing[create-matrix4x4 (vec3 vec3 vec3 vec3 -> matrix4x4)]{ - @racket[(create-matrix4x4 a b c d)] erweitert jeden Vektor in einen 4D-Vektor und kombiniert diese zu - einer Matrix @racket[a], @racket[b], @racket[c] und @racket[d], wobei - @racket[a], @racket[b], @racket[c] mit 0 und @racket[d] mit 1 erweitert wird, um eine homogene Matrix zu erzeugen. -} - -@defthing[transpose-matrix4x4 (matrix4x4 -> matrix4x)]{ - @racket[(transpose-matrix4x4 m)] erstellt die transponierte Matrix @racket[m]^@racket[T]. -} - -@defthing[multiply-matrix-vec4 (matrix vec4 -> vec4)]{ - @racket[(multiply-matrix-vec4 m v)] gibt die Matrix @racket[m]@racket[v] zurück. Die @racket[w]-Komponente ist nicht normalisiert. -} - -@defthing[transform-vec3 (matrix4x4 vec3 -> vec3)]{ - @racket[(transform-vec3 m v)] erweitert @racket[v] mit 1, multipliziert @racket[m] mit @racket[v] und dividiert das Ergebnis mit @racket[w]. -} - -@defthing[multiply-matrix (matrix4x4 matrix4x4 -> matrix4x4)]{ - @racket[(multiply-matrix a b)] gibt die Matrix @racket[a]*@racket[b] zurück. -} - -@defthing[create-translation-matrix (vec3 -> matrix4x4)]{ - @racket[(create-translation-matrix v)] gibt die Translations-Matrix zurück. -} - -@defthing[create-rotation-x-matrix (number -> matrix4x4)]{ - @racket[(create-rotation-x-matrix a)] gibt eine Rotations-Matrix zurück die um die X-Achse mit dem Winkel @racket[a] rotiert. -} - -@defthing[create-rotation-y-matrix (number -> matrix4x4)]{ - @racket[(create-rotation-y-matrix a)] gibt eine Rotations-Matrix zurück die um die Y-Achse mit dem Winkel @racket[a] rotiert. -} - -@defthing[create-rotation-z-matrix (number -> matrix4x4)]{ - @racket[(create-rotation-z-matrix a)] gibt eine Rotations-Matrix zurück die um die Z-Achse mit dem Winkel @racket[a] rotiert. -} - -@defthing[create-lookat-matrix (vec3 vec3 vec3 -> matrix4x4)]{ - @racket[(create-lookat-matrix pos lookat up)] gibt eine Kameramatrix. Ursprungspunkt ist @racket[pos], die Z-Achse zeigt auf @racket[lookat]. -} - -@defthing[create-projection-matrix (number -> matrix4x4)]{ - @racket[(create-projection-matrix vertical-fov/2)] erzeugt eine Projektions-Matrix. @racket[vertical-fov]/2 gibt den vertikalen Winkel der Ansicht dividiert durch 2 an. -} - -@defthing[create-viewport-matrix (natural natural -> matrix4x4)]{ - @racket[(create-viewport-matrix width height)] gibt einen Ausschnitt an. -} - -@;------------------------------------------------------------------------------------- -@section[#:tag "3dline"]{3d-Linien} - - -@defthing[line3d signature]{ - Eine @deftech{3d-Linie} @racket[line3d] ist ein Record, der durch den Aufruf @racket[make-line3d] erstellt wird und eine farbige Linie zwischen zwei Punkten - im 3-dimensionalen Raum darstellt. -} - -@defthing[make-line3d (vec3 vec3 color -> line3d)]{ - @racket[(make-line3d a b col)] erstellt eine 3D-Linie zwischen Punkt @racket[a] und Punkt @racket[b] mit der Farbe @racket[col]. -} - -@defthing[line3d-a (line3d -> vec3)]{ - extrahiert den Anfangspunkt einer 3D-Linie.} - -@defthing[line3d-b (line3d -> vec3)]{ - extrahiert den Endpunkt einer 3D-Linie.} - -@defthing[line3d-color (line3d -> color)]{ - extrahiert die Farbe einer 3D-Linie.} - -@defthing[create-box (number number number color -> (list-of line3d))]{ - @racket[(create-box width height depth color)] erstellt eine Box am Punkt (0,0,0) in den angebenen Ausmaßen. -} - -@defthing[transform-primitive-list ((list-of line3d) matrix4x4 -> (list-of line3d))]{ - @racket[(transform-primitive-list scene transformationr)] wendet @racket[transformation] auf alle Punkte der Linien in @racket[scene] an und gibt - diese zurück. -} Binary files /tmp/tmp0gsW68/xZwWv_wqW8/racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/p1.jpg and /tmp/tmp0gsW68/cUaTt6TkRm/racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/p1.jpg differ Binary files /tmp/tmp0gsW68/xZwWv_wqW8/racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/p2.jpg and /tmp/tmp0gsW68/cUaTt6TkRm/racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/p2.jpg differ Binary files /tmp/tmp0gsW68/xZwWv_wqW8/racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/p3.jpg and /tmp/tmp0gsW68/cUaTt6TkRm/racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/p3.jpg differ Binary files /tmp/tmp0gsW68/xZwWv_wqW8/racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/p4.jpg and /tmp/tmp0gsW68/cUaTt6TkRm/racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/p4.jpg differ diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/sdp-lib.scrbl racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/sdp-lib.scrbl --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/sdp-lib.scrbl 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/sdp-lib.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,44 @@ +#lang scribble/doc +@(require scribble/manual + scribble/eval + (for-label scheme/base + scheme/contract + scheme/class + scheme/gui/base + lang/posn + lang/imageeq + lang/prim)) + +@(define sdp @italic{Schreibe Dein Programm!}) +@(define (sdp-ref s) @secref[#:doc '(lib "deinprogramm/scribblings/deinprogramm.scrbl") s]) + +Note: This is documentation for the language levels that go with the +German textbook @italic{@link["http://www.deinprogramm.de/sdp/"]{Schreibe +Dein Programm!}}. + +@title{@bold{sdp}: Sprachen als Libraries} + +@; ------------------------------------------------------------ +@section{@italic{Schreibe Dein Programm} - Anfänger} + +@defmodule[deinprogramm/sdp/beginner] + +Das Modul @racketmodname[deinprogramm/sdp/beginner] implementiert die +Anfängersprache für @|sdp|; siehe @sdp-ref["sdp-beginner"]. + +@; ------------------------------------------------------------ +@section{@italic{Schreibe Dein Programm!}} + +@defmodule[deinprogramm/sdp/vanilla] + +Das Modul @racketmodname[deinprogramm/sdp/vanilla] implementiert die +Standardsprache für @|sdp|; siehe @sdp-ref["sdp-vanilla"]. + +@; ------------------------------------------------------------ +@section{@italic{Schreibe Dein Programm!} - fortgeschritten} + +@defmodule[deinprogramm/sdp/advanced] + +Das Modul @racketmodname[deinprogramm/sdp/advanced] implementiert +die fortgeschittene Sprachebene für @|sdp|; siehe +@sdp-ref["sdp-advanced"]. diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/sound.scrbl racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/sound.scrbl --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/sound.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/sound.scrbl 1970-01-01 00:00:00.000000000 +0000 @@ -1,30 +0,0 @@ -#lang scribble/doc - -@(require scribble/manual scribble/struct "shared.rkt" - (for-label scheme teachpack/deinprogramm/sound)) - -@teachpack["sound"]{Abspielen von Audio-Dateien} - -Note: This is documentation for the @filepath{sound.rkt} teachpack that goes -with the German textbook -@italic{@link["http://www.deinprogramm.de/dmda/"]{Die Macht der -Abstraktion}}. - -Dieses Teachpack definiert eine Prozedur zum Abspielen einer -Audio-Datei. Diese Prozedur ist je nach Plattform unterschiedlich -realisiert, und funktioniert möglicherweise nicht auf jedem -Rechner. - -@declare-exporting[teachpack/deinprogramm/sound] - -@defthing[play-sound-file (string -> unspecific)]{ -Der Aufruf -@racket[(play-sound-file f)] spielt die Audio-Datei mit dem Namen -@racket[f] ab.} - -@defthing[background-play-sound-file (string -> unspecific)]{ -Der Aufruf -@racket[(background-play-sound-file f)] spielt die Audio-Datei mit dem Namen -@racket[f] im Hintergrund ab, also ohne dass das Scheme-Programm anhält.} - - diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/std-grammar.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/std-grammar.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/std-grammar.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/std-grammar.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -2,14 +2,14 @@ #lang scheme/base (require scribblings/htdp-langs/common scribble/decode - (for-label deinprogramm/DMdA-beginner)) + (for-label deinprogramm/sdp/beginner)) (provide prim-nonterms - racketgrammar*-DMdA) + racketgrammar*-sdp) (define ex-str "Dies ist eine Zeichenkette, die \" enthält.") -(define-syntax-rule (racketgrammar*-DMdA +(define-syntax-rule (racketgrammar*-sdp #:literals (lit ...) (def-rule ...) (prod ...) @@ -42,7 +42,7 @@ @#,racket[string] @#,racket[(lambda (id (... ...)) expr)] @#,racket[(λ (id (... ...)) expr)] - @#,racket[(code:line id (code:comment @#,seclink["id"]{Bezeichner}))] + @#,racket[(code:line id (code:comment @#,seclink["id"]{Name}))] @#,racket[(cond (expr expr) (expr expr) (... ...))] @#,racket[(cond (expr expr) (... ...) (else expr))] @#,racket[(if expr expr)] @@ -60,6 +60,7 @@ @#,racket[(mixed sig (... ...))] @#,racket[(code:line (sig (... ...) -> sig) (code:comment @#,seclink["proc-signature"]{Prozedur-Signatur}))] @#,racket[(list-of sig)] + @#,racket[(nonempty-list-of sig)] @#,racket[(code:line %a %b %c (code:comment @#,seclink["signature-variable"]{Signatur-Variable}))] @#,racket[(combined sig (... ...))] signature-rule ... diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/turtle.scrbl racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/turtle.scrbl --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/turtle.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/turtle.scrbl 1970-01-01 00:00:00.000000000 +0000 @@ -1,178 +0,0 @@ -#lang scribble/doc - -@(require scribble/manual scribble/struct "shared.rkt" - (for-label scheme - teachpack/deinprogramm/image - teachpack/deinprogramm/turtle)) - -@teachpack["turtle"]{Turtle-Grafik} - -Note: This is documentation for the @filepath{turtle.rkt} teachpack that goes -with the German textbook -@italic{@link["http://www.deinprogramm.de/dmda/"]{Die Macht der -Abstraktion}}. - -@declare-exporting[teachpack/deinprogramm/turtle #:use-sources (teachpack/deinprogramm/turtle)] - -Turtle-Grafik ist eine Methode zum Erstellen von Computergrafiken. Das -Zeichnen wird dabei durch das Bewegen einer virtuellen Schildkröte -über den Zeichenbereich modelliert. Eine Schildkröte kann durch drei -Befehle bewegt werden: - -@itemize[ - @item{@racket[(move n)] Bewegt die Schildkröte um @racket[n] Pixel ohne zu zeichnen.} - @item{@racket[(draw n)] Bewegt die Schildkröte um @racket[n] Pixel und zeichnet dabei.} - @item{@racket[(turn n)] Dreht die Schildkröte um n Grad im Uhrzeigersinn.} -] - -Wir stellen jetzt ein Teachpack für DrRacket vor, mit dessen Hilfe -solche Turtle-Grafiken erstellt werden können. - -@section{Tutorial} - -Unser Ziel ist es, in diesem Tutorial ein Quadrat mithilfe der -Prozeduren des Teachpacks zu zeichnen. Aus diesem Grund müssen wir -zunächst mit der Prozedur @racket[draw] eine Linie nach rechts malen. Die -initiale Ausgansposition der Turtle ist in der Bildmitte mit Blick -nach rechts. Mit @racket[(draw 20)] bewegen wir die Turtle dann 20 Pixel nach -rechts und zeichnen dabei. Um das resultierende Bild zu sehen ist, -müssen wir die Turtle mittels der Prozedur run laufen lassen. Die -restlichen Parameter für run sind die Höhe und die Breite des Bildes -sowie die Farbe, in der gezeichnet werden soll. Geben Sie also -folgenden Befehl in die REPL ein, um Ihre erste Turtle-Grafik zu -erstellen: - -@racketblock[ -(run (draw 20) 100 100 "red") -] - -Sie erhalten dann eine Ausgabe wie die folgende: - -@image["p1.jpg"] - -Nun vervollständigen wir die Linie zu einem rechten Winkel: wir drehen -die Turtle um 90° nach rechts und zeichnen dann eine Line der Länge 20 -Pixel nach unten. Zum Drehen einer Turtle verwenden wir die Prozedur -@racket[turn]. - -Da wir ein Quadrat aus zwei rechten Winkeln zusammensetzen können, -abstrahieren wir über das Zeichnen des rechten Winkels. Dazu schreiben -wir eine Prozedur @racket[right-angle] die als Parameter eine Turtle -erhält: - -@racketblock[ -(: right-angle (turtle -> turtle)) -(define right-angle - (lambda (t1) - (let* ((t2 ((draw 20) t1)) - (t3 ((turn -90) t2)) - (t4 ((draw 20) t3))) - t4))) -] - -Das Ergebnis sieht dann so aus: - -@image["p2.jpg"] - -Um das Quadrat komplett zu zeichnen, sollen nun zwei rechte Winkel -verwendet werden. Wir zeichnen also einen rechten Winkel, drehen uns -um 90° nach rechts, und zeichnen einen zweiten rechten Winkel. - -@racketblock[ -(: square (turtle -> turtle)) -(define square - (lambda (t1) - (let* ((t2 (right-angle t1)) - (t3 ((turn -90) t2)) - (t4 (right-angle t3))) - t4))) -] - -So sieht das Ergebnis aus: - -@image["p3.jpg"] - -@subsection{Verbesserungen} - -An dem Beispiel ist leicht zu sehen, dass es zum Zeichnen mit Hilfe -von Turtle-Grafik oft erforderlich ist, Zwischenwerte wie @racket[t1], -@racket[t2] etc., an die nächste Prozedur weiterzureichen, die Werte -ansonsten aber nicht weiterverwendet werden. Beispielsweise werden in -der obigen Definition von square die Variablen @racket[t1], ..., -@racket[t4] nur gebraucht, um die Prozeduren @racket[right-angle], -@racket[(turn -90)] und @racket[right-angle] hintereinander -auszuführen. - -Um solche Fälle einfach programmieren zu können, enthält das -Turtle-Teachpack die Prozedur @racket[sequence]. Damit können wir eine -zu @racket[right-angle] äquivalente Version wesentlicher einfacher -aufschreiben: - -@racketblock[ -(define right-angle2 - (sequence (draw 20) (turn -90) (draw 20))) -] - -Ebenso wie @racket[right-angle] können wir square leichter schreiben als: - -@racketblock[ -(define square2 - (sequence right-angle (turn -90) right-angle)) -] - -@section{Prozeduren} - -@declare-exporting[teachpack/deinprogramm/turtle] - -@defthing[turtle signature]{ -Dies ist die Signatur für Turtles. -} - -@defthing[set-color (color -> (turtle -> turtle))]{ Diese Prozedur ist -eine Prozedurfabrik. Sie liefert als Ergebnis eine Prozedur, die auf -eine Turtle anwendbar ist. Wendet man das Ergebnis auf eine Turtle an, -so ändert dies die Farbe mit der gezeichnet wird. - -Folgender Code - -@racketblock[ -(define square3 - (sequence right-angle (turn -90) (set-color "blue") right-angle)) -] -liefert dieses Bild: - -@image["p4.jpg"] -} - -@defthing[turn (number -> (turtle -> turtle))]{ Diese Prozedur ist -eine Prozedurfabrik. Sie liefert als Ergebnis eine Prozedur, die auf -eine Turtle anwendbar ist. Wendet man das Ergebnis auf eine Turtle an, -so ändert sich die Blickrichtung der Turtle um die gegebene Gradzahl -gegen den Uhrzeigersinn. -} - -@defthing[draw (number -> (turtle -> turtle))]{ Diese Prozedur ist -eine Prozedurfabrik. Sie liefert als Ergebnis eine Prozedur, die auf -eine Turtle anwendbar ist. Wendet man das Ergebnis auf eine Turtle an, -so bewegt sich die Schildkröte um die gegebene Anzahl von Pixel und -zeichnet dabei eine Linie.} - -@defthing[move (number -> (turtle -> turtle))]{ Diese Prozedur ist eine -Prozedurfabrik. Sie liefert als Ergebnis eine Prozedur, die auf ein -Turtle anwendbar ist. Wendet man das Ergebnis auf eine Turtle an, so -bewegt sich die Schildkröte um die gegebene Anzahl von Pixel, zeichnet -dabei aber keine Linie.} - -@defthing[run ((turtle -> turtle) number number color -> image)]{ -Diese Prozedur wendet die übergebene Prozedur von Turtle nach Turtle -auf die initiale Schildkröte an und zeigt das daraus resultierende -Bild an. Der zweite Parameter ist die Höhe des Bilds, der dritte -Parameter die Breite des Bilds und der vierte Parameter die Farbe, mit -der gezeichnet wird. -} - -@defthing[sequence ((turtle -> turtle) ... -> (turtle -> turtle))]{ -Diese Prozedur nimmt eine beliebige Anzahl von Turtle-Veränderungen -(d.h. Prozeduren mit Signatur @racket[turtle -> turtle]) und erstellt -eine neue Prozedur, die die Veränderungen der Reihe nach von links -nach rechts abarbeitet.} diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/vanilla.scrbl racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/vanilla.scrbl --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/vanilla.scrbl 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/vanilla.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,125 @@ +#lang scribble/doc +@(require scribblings/htdp-langs/common "std-grammar.rkt" "prim-ops.rkt" + (for-label deinprogramm/sdp/vanilla + (only-in deinprogramm/sdp/beginner define))) + +@title[#:style 'toc #:tag "sdp-vanilla"]{Schreibe Dein Programm!} + +This is documentation for the language level @italic{Schreibe Dein Programm!} +to go with the German textbooks +@italic{Schreibe Dein Programm!}. + +@declare-exporting[deinprogramm/sdp/vanilla #:use-sources (deinprogramm/sdp/private/primitives)] + +@racketgrammar*-sdp[ +#:literals () +() () +( + @#,racket[(let ((id expr) (... ...)) expr)] + @#,racket[(letrec ((id expr) (... ...)) expr)] + @#,racket[(let* ((id expr) (... ...)) expr) ] +) +( + @#,racket[(list-of sig)] + @#,racket[(nonempty-list-of sig)] +) +( + @#,racket[empty] + @#,racket[(make-pair pattern pattern)] + @#,racket[(list pattern ...)] +) +] + +@|prim-nonterms| + +@prim-ops['(lib "vanilla.rkt" "deinprogramm" "sdp") #'here] + +@section[#:tag "signatures-vanilla"]{Signaturen} + +@defidform[empty-list]{ +Signatur für die leere Liste. +} + +@defform[(list-of sig)]{ +Diese Signatur ist dann für einen Wert gültig, wenn dieser eine Liste ist, +für dessen Elemente @racket[sig] gültig ist. +} + +@defform[(nonempty-list-of sig)]{ +Diese Signatur ist dann für einen Wert gültig, wenn dieser eine nichtleere Liste ist, +für dessen Elemente @racket[sig] gültig ist. +} + +@section{@racket[let], @racket[letrec] und @racket[let*]} + +@defform[(let ((id expr) ...) expr)]{ + +Bei einem @racket[let]-Ausdruck werden zunächst die @racket[expr]s aus +den @racket[(id expr)]-Paaren ausgewertet. Ihre Werte werden dann im +Rumpf-@racket[expr] für die Namen @racket[id] eingesetzt. Dabei können +sich die Ausdrücke nicht auf die Namen beziehen. + +@racketblock[ +(define a 3) +(let ((a 16) + (b a)) + (+ b a)) +=> 19] + +Das Vorkommen von @racket[a] in der Bindung von @racket[b] bezieht +sich also auf das @racket[a] aus der Definition, nicht das @racket[a] +aus dem @racket[let]-Ausdruck. +} + +@defform[(letrec ((id expr) ...) expr)]{ +Ein @racket[letrec]-Ausdruck ist +ähnlich zum entsprechenden @racket[let]-Ausdruck, mit dem Unterschied, daß sich +die @racket[expr]s aus den Bindungen auf die gebundenen Namen beziehen +dürfen.} + +@defform[(let* ((id expr) ...) expr)]{ +Ein @racket[let*]-Ausdruck ist ähnlich zum entsprechenden +@racket[let]-Ausdruck, mit dem Unterschied, daß sich die @racket[expr]s +aus den Bindungen auf die Namen beziehen dürfen, die jeweils vor dem +@racket[expr] gebunden wurden. Beispiel: + +@racketblock[ +(define a 3) +(let* ((a 16) + (b a)) + (+ b a)) +=> 32] + +Das Vorkommen von @racket[a] in der Bindung von @racket[b] bezieht +sich also auf das @racket[a] aus dem @racket[let*]-Ausdruck, nicht das +@racket[a] aus der globalen Definition. +} + +@section[#:tag "pattern-matching-vanilla"]{Pattern-Matching} + +@defform/none[(match expr (pattern expr) ...) + #:grammar [(pattern + ... + empty + (make-pair pattern pattern) + (list pattern ...) + )]]{ +Zu den Patterns aus der "Anfänger"-Sprache kommen noch drei neue hinzu: + +@itemlist[ +@item{Das Pattern @racket[empty] paßt auf die leere Liste.} + +@item{Das Pattern @racket[(make-pair pattern pattern)] paßt auf Paare, bei + denen die beiden inneren Patterns auf @racket[first] bzw. @racket[rest] passen.} + +@item{Das Pattern [(list pattern ...)] paßt auf Listen, die genauso +viele Elemente haben, wie Teil-Patterns im @racket[list]-Pattern +stehen und bei denen die inneren Patterns auf die Listenelemente +passen. +} +] +} + +@section[#:tag "vanilla-prim-op"]{Primitive Operationen} + +@prim-op-defns['(lib "vanilla.rkt" "deinprogramm" "sdp") #'here '()] diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/world.scrbl racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/world.scrbl --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/scribblings/world.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/scribblings/world.scrbl 1970-01-01 00:00:00.000000000 +0000 @@ -1,80 +0,0 @@ -#lang scribble/doc - -@(require scribble/manual scribble/struct "shared.rkt" - (for-label scheme - teachpack/deinprogramm/image - teachpack/deinprogramm/world)) - -@teachpack["world"]{Animationen} - -Note: This is documentation for the @filepath{world.rkt} teachpack that goes -with the German textbook -@italic{@link["http://www.deinprogramm.de/dmda/"]{Die Macht der -Abstraktion}}. - -Dieses Teachpack ermöglicht, kleine Animationen und Spiele zu programmieren. -Es enthält alle Prozeduren aus dem -@seclink["image"]{image-Teachpack}. - -@declare-exporting[teachpack/deinprogramm/world #:use-sources (deinprogramm/world)] - -@defthing[world signature]{ -Eine @deftech{Welt} (Name: @racket[world]) ist die Repräsentation des Zustands, -der durch die Animation abgebildet wird. -} - -@defthing[mouse-event-kind signature]{ -@racket[(one-of "enter" "leave" "motion" "left-down" "left-up" "middle-down" "middle-up" "right-down" "right-up")] - -Eine @deftech{Mausereignis-Art} (Name: @racket[mouse-event-kind]) -bezeichnet die Art eines Maus-Ereignisses: - -@racket["enter"] bedeutet, daß der Mauszeiger gerade -in das Fenster hinein bewegt wurde. @racket["leave"] bedeutet, daß der -Mauszeiger gerade aus dem Fenster heraus bewegt wurde. -@racket["motion"] bedeutet, daß der Mauszeiger innerhalb des -Fensters bewegt wurde. Die anderen Zeichenketten bedeuten, daß der -entsprechende Mausknopf gedrückt oder losgelassen wurde.} - -@defthing[big-bang (natural natural number world -> (one-of #t))]{ -Der Aufruf @racket[(big-bang w h n w)] -erzeugt eine Leinwand mit Breite @racket[w] und Höhe -@racket[h], startet die Uhr, die alle @racket[n] Sekunden -tickt, und macht @racket[w] zur ersten Welt.} - -@defthing[on-tick-event ((world -> world) -> (one-of #t))]{ -Der Aufruf @racket[(on-tick-event tock)] -meldet @racket[tock] -als Prozedur an, die bei jedem Uhren-Tick aufgerufen wird, um aus -der alten Welt eine neue zu machen.} - -@defthing[on-key-event ((world string -> world) -> (one-of #t))]{ -Der Aufruf @racket[(on-key-event change)] -meldet @racket[change] -als Prozedur an, die bei jedem Tastendruck aufgerufen wird, um aus -der alten Welt eine neue zu machen. Dabei wird als Argument eine -Zeichenkette übergeben, welche die Taste darstellt, also -@racket["a"] für die A-Taste etc., sowie @racket["up"], -@racket["down"], @racket["left"], und @racket["right"] -für die entsprechenden Pfeiltasten und @racket["wheel-up"] für die -Bewegung des Mausrads nach oben und @racket["wheel-down"] für die -Bewegung des Mausrads nach unten.} - -@defthing[on-mouse-event ((world natural natural mouse-event-kind -> world) -> (one-of #t))]{ -Der Aufruf @racket[(on-mouse-event change)] -meldet @racket[change] -als Prozedur an, die bei jedem Mausereignis aufgerufen wird, um aus -der alten Welt eine neue zu machen. Die @racket[change]-Prozedur -wird als @racket[(change w x y k)] aufgerufen. Dabei ist @racket[w] -die alte Welt, @racket[x] und @racket[y] die Koordinaten des -Mauszeigers, und @racket[k] die Art des Mausereignisses.} - -@defthing[on-redraw ((world -> image) -> (one-of #t))]{ -Der Aufruf @racket[(world->image world->image)] -meldet die -Prozedur @racket[world->image] an, die aus einer Welt -ein Bild macht, das auf der Leinwand dargestellt wird.} - -@defthing[end-of-time (string -> world)]{ -Diese Prozedur hält die Welt an und druckt ihr Argument in der REPL aus.} - diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/advanced/lang/reader.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/advanced/lang/reader.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/advanced/lang/reader.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/advanced/lang/reader.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,2 @@ +#lang s-exp syntax/module-reader +deinprogramm/sdp/advanced diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/advanced.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/advanced.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/advanced.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/advanced.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,18 @@ +#lang deinprogramm/sdp + +(require syntax/docprovide "deflam.rkt") +(provide #%app #%top (rename-out (sdp-module-begin #%module-begin)) #%datum #%top-interaction + require lib planet provide + let let* letrec lambda λ define + cond if else and or quote + define-record-functions + match + .. ... .... ..... ...... + check-expect check-within check-error check-member-of check-range check-satisfied + check-property for-all ==> expect expect-within expect-member-of expect-range + signature contract : define-contract -> mixed one-of predicate combined list-of nonempty-list-of + number real rational integer natural boolean true false string symbol empty-list any property) +(provide-and-document + procedures + (all-from advanced: deinprogramm/sdp/private/primitives procedures)) + diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/avanced-reader.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/avanced-reader.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/avanced-reader.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/avanced-reader.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,6 @@ +#lang scheme/base +(require deinprogramm/sdp/private/sdp-reader) +(provide (rename-out (-read-syntax read-syntax)) + (rename-out (-read read))) +(define -read-syntax (make-read-syntax '(lib "advanced.ss" "deinprogramm" "sdp"))) +(define -read (make-read '(lib "advanced.ss" "deinprogramm" "sdp"))) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/beginner/lang/reader.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/beginner/lang/reader.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/beginner/lang/reader.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/beginner/lang/reader.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,2 @@ +#lang s-exp syntax/module-reader +deinprogramm/sdp/beginner diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/beginner-reader.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/beginner-reader.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/beginner-reader.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/beginner-reader.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,6 @@ +#lang scheme/base +(require deinprogramm/sdp/private/sdp-reader) +(provide (rename-out (-read-syntax read-syntax)) + (rename-out (-read read))) +(define -read-syntax (make-read-syntax '(lib "beginner.rkt" "deinprogramm" "sdp"))) +(define -read (make-read '(lib "beginner.rkt" "deinprogramm" "sdp"))) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/beginner.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/beginner.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/beginner.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/beginner.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,22 @@ +#lang deinprogramm/sdp + +(require syntax/docprovide) +(provide #%app #%top (rename-out (sdp-module-begin #%module-begin)) #%datum #%top-interaction + require lib planet provide + define lambda λ cond if else and or + define-record-functions + match + .. ... .... ..... ...... + check-expect check-within check-error check-member-of check-range check-satisfied + check-property for-all ==> expect expect-within expect-member-of expect-range + signature contract : define-contract -> mixed one-of predicate combined + number real rational integer natural boolean true false string any property) +(provide-and-document + procedures + (all-from-except beginner: deinprogramm/sdp/private/primitives procedures + set! eq? equal? + quote + empty empty? cons cons? first rest + length map for-each reverse append list list-ref fold filter + symbol? symbol=? string->symbol symbol->string + apply)) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/deflam.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/deflam.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/deflam.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/deflam.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,11 @@ +#lang deinprogramm/sdp + +;; this file exists so there is a single file that exports +;; identifiers named 'define' and 'lambda' that are the +;; advanced versions of 'define' and 'lambda', +;; so that we can tell scribble about this file and then it +;; can connect up the re-exports to the documentation properly. + +(provide (rename-out (sdp-advanced-lambda lambda)) + (rename-out (sdp-advanced-lambda λ)) + (rename-out (sdp-advanced-define define))) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/lang/reader.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/lang/reader.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/lang/reader.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/lang/reader.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,2 @@ +#lang s-exp syntax/module-reader +deinprogramm/sdp/private/primitives diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/private/convert-explicit.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/private/convert-explicit.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/private/convert-explicit.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/private/convert-explicit.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,90 @@ +#lang racket/base +(provide convert-explicit) + +(require mzlib/pretty + mzlib/struct) + +(require deinprogramm/private/explicit-write) + +(require deinprogramm/signature/signature-german + (only-in deinprogramm/signature/signature + signature? signature-name)) + +; I HATE DEFINE-STRUCT! +(define-struct/properties :empty-list () + ((prop:custom-write + (lambda (r port write?) + (write-string "#" port)))) + (make-inspector)) + +(define-struct/properties :signature (sig) + ((prop:custom-write + (lambda (r port write?) + (cond + ((signature-name (:signature-sig r)) + => (lambda (n) + (write-string "#string n) port) + (write-string ">" port))) + (else + (write-string "#" port)))))) + (make-inspector)) + +;; might be improper +(define-struct/properties :list (elements) + ((prop:custom-write (make-constructor-style-printer + (lambda (obj) 'list) + (lambda (obj) (:list-elements obj))))) + (make-inspector)) + +; we wrap procedures in this so we can print them as # +(struct :function (func) + #:property prop:custom-write + (lambda (r port write?) + (cond + ((object-name (:function-func r)) + => (lambda (n) + (write-string "#string n) port) + (write-string ">" port))) + (else + (write-string "#")))) + #:property prop:procedure (struct-field-index func) + #:inspector (make-inspector)) + +(define (convert-explicit v) + (let ((hash (make-hasheq))) + (let recur ((v v)) + (cond + ((null? v) (make-:empty-list)) ; prevent silly printing of sharing + ((signature? v) (make-:signature v)) + ((procedure? v) (:function v)) + ((pair? v) + (make-:list + (let list-recur ((v v)) + (cond + ((null? v) + v) + ((not (pair? v)) + '()) ; the stepper feeds all kinds of garbage in here + (else + (cons (recur (car v)) + (list-recur (cdr v)))))))) + ((struct? v) + (or (hash-ref hash v #f) + (let-values (((ty skipped?) (struct-info v))) + (cond + ((and ty (lazy-wrap? ty)) + (let ((lazy-wrap-info (lazy-wrap-ref ty))) + (let ((constructor (lazy-wrap-info-constructor lazy-wrap-info)) + (raw-accessors (lazy-wrap-info-raw-accessors lazy-wrap-info))) + (let ((val (apply constructor (map (lambda (raw-accessor) + (recur (raw-accessor v))) + raw-accessors)))) + (hash-set! hash v val) + val)))) + (else v))))) + (else + v))))) + + diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/private/primitives.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/private/primitives.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/private/primitives.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/private/primitives.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,1334 @@ +#lang scheme/base + +(require syntax/docprovide) + +(require test-engine/scheme-tests + (lib "test-info.scm" "test-engine") + test-engine/scheme-tests + scheme/class) + +(require deinprogramm/signature/module-begin + (except-in deinprogramm/signature/signature signature-violation) + (except-in deinprogramm/signature/signature-syntax property)) + +(require (for-syntax scheme/base) + (for-syntax stepper/private/syntax-property) + (for-syntax syntax/parse) + (for-syntax racket/struct-info) + syntax/parse) + +(require deinprogramm/sdp/record) + +(require (only-in lang/private/teachprims define-teach teach-equal? beginner-equal~?)) + +(require (for-syntax deinprogramm/private/syntax-checkers)) + +(require (for-syntax "rewrite-error-message.rkt")) +(require "rewrite-error-message.rkt") + +(require (rename-in deinprogramm/quickcheck/quickcheck + (property quickcheck:property))) + +(provide provide lib planet rename-out require #%datum #%module-begin #%top-interaction) ; so we can use this as a language + +(provide (all-from-out deinprogramm/sdp/record)) +(provide (all-from-out test-engine/scheme-tests)) +(provide signature define-contract : + contract ; legacy + -> mixed one-of predicate combined list-of nonempty-list-of) + +(provide number real rational integer natural + boolean true false + string symbol + empty-list + unspecific + any + property) + +(provide match) + +(define-syntax provide/rename + (syntax-rules () + ((provide/rename (here there) ...) + (begin + (provide (rename-out (here there))) ...)))) + +(provide/rename + (sdp-define define) + (sdp-let let) + (sdp-let* let*) + (sdp-letrec letrec) + (sdp-lambda lambda) + (sdp-lambda λ) + (sdp-cond cond) + (sdp-if if) + (sdp-else else) + (sdp-begin begin) + (sdp-and and) + (sdp-or or) + (sdp-dots ..) + (sdp-dots ...) + (sdp-dots ....) + (sdp-dots .....) + (sdp-dots ......) + (sdp-app #%app) + (sdp-top #%top) + (sdp-set! set!) + (module-begin sdp-module-begin)) + +(provide sdp-advanced-lambda + sdp-advanced-define) + +(provide for-all ==> + check-property + expect expect-within expect-member-of expect-range) + +(provide quote) + +(provide-and-document + procedures + ("Zahlen" + (number? (any -> boolean) + "feststellen, ob ein Wert eine Zahl ist") + + (= (number number number ... -> boolean) + "Zahlen auf Gleichheit testen") + (< (real real real ... -> boolean) + "Zahlen auf kleiner-als testen") + (> (real real real ... -> boolean) + "Zahlen auf größer-als testen") + (<= (real real real ... -> boolean) + "Zahlen auf kleiner-gleich testen") + (>= (real real real ... -> boolean) + "Zahlen auf größer-gleich testen") + + (+ (number number number ... -> number) + "Summe berechnen") + (- (number number ... -> number) + "bei mehr als einem Argument Differenz zwischen der ersten und der Summe aller weiteren Argumente berechnen; bei einem Argument Zahl negieren") + (* (number number number ... -> number) + "Produkt berechnen") + (/ (number number number ... -> number) + "das erste Argument durch das Produkt aller weiteren Argumente berechnen") + (max (real real ... -> real) + "Maximum berechnen") + (min (real real ... -> real) + "Minimum berechnen") + (quotient (integer integer -> integer) + "ganzzahlig dividieren") + (remainder (integer integer -> integer) + "Divisionsrest berechnen") + (modulo (integer integer -> integer) + "Divisionsmodulo berechnen") + (sqrt (number -> number) + "Quadratwurzel berechnen") + (expt (number number -> number) + "Potenz berechnen (erstes Argument hoch zweites Argument)") + (abs (real -> real) + "Absolutwert berechnen") + + ;; fancy numeric + (exp (number -> number) + "Exponentialfunktion berechnen (e hoch Argument)") + (log (number -> number) + "natürlichen Logarithmus (Basis e) berechnen") + + ;; trigonometry + (sin (number -> number) + "Sinus berechnen (Argument in Radian)") + (cos (number -> number) + "Cosinus berechnen (Argument in Radian)") + (tan (number -> number) + "Tangens berechnen (Argument in Radian)") + (asin (number -> number) + "Arcussinus berechnen (in Radian)") + (acos (number -> number) + "Arcuscosinus berechnen (in Radian)") + (atan (number -> number) + "Arcustangens berechnen (in Radian)") + + (exact? (number -> boolean) + "feststellen, ob eine Zahl exakt ist") + + (integer? (any -> boolean) + "feststellen, ob ein Wert eine ganze Zahl ist") + (natural? (any -> boolean) + "feststellen, ob ein Wert eine natürliche Zahl (inkl. 0) ist") + + (zero? (number -> boolean) + "feststellen, ob eine Zahl Null ist") + (positive? (number -> boolean) + "feststellen, ob eine Zahl positiv ist") + (negative? (number -> boolean) + "feststellen, ob eine Zahl negativ ist") + (odd? (integer -> boolean) + "feststellen, ob eine Zahl ungerade ist") + (even? (integer -> boolean) + "feststellen, ob eine Zahl gerade ist") + + (lcm (integer integer ... -> natural) + "kleinstes gemeinsames Vielfaches berechnen") + + (gcd (integer integer ... -> natural) + "größten gemeinsamen Teiler berechnen") + + (rational? (any -> boolean) + "feststellen, ob eine Zahl rational ist") + + (numerator (rational -> integer) + "Zähler eines Bruchs berechnen") + + (denominator (rational -> natural) + "Nenner eines Bruchs berechnen") + + (inexact? (number -> boolean) + "feststellen, ob eine Zahl inexakt ist") + + (real? (any -> boolean) + "feststellen, ob ein Wert eine reelle Zahl ist") + + (floor (real -> integer) + "nächste ganze Zahl unterhalb einer rellen Zahlen berechnen") + + (ceiling (real -> integer) + "nächste ganze Zahl oberhalb einer rellen Zahlen berechnen") + + (round (real -> integer) + "relle Zahl auf eine ganze Zahl runden") + + (complex? (any -> boolean) + "feststellen, ob ein Wert eine komplexe Zahl ist") + + (make-polar (real real -> number) + "komplexe Zahl aus Abstand zum Ursprung und Winkel berechnen") + + (real-part (number -> real) + "reellen Anteil einer komplexen Zahl extrahieren") + + (imag-part (number -> real) + "imaginären Anteil einer komplexen Zahl extrahieren") + + (magnitude (number -> real) + "Abstand zum Ursprung einer komplexen Zahl berechnen") + + (angle (number -> real) + "Winkel einer komplexen Zahl berechnen") + + (exact->inexact (number -> number) + "eine Zahl durch eine inexakte Zahl annähern") + + (inexact->exact (number -> number) + "eine Zahl durch eine exakte Zahl annähern") + + ;; "Odds and ends" + + (number->string (number -> string) + "Zahl in Zeichenkette umwandeln") + + (string->number (string -> (mixed number false)) + "Zeichenkette in Zahl umwandeln, falls möglich") + + (random (natural -> natural) + "eine natürliche Zufallszahl berechnen, die kleiner als das Argument ist") + + (current-seconds (-> natural) + "aktuelle Zeit in Sekunden seit einem unspezifizierten Startzeitpunkt berechnen")) + + ("boolesche Werte" + (boolean? (any -> boolean) + "feststellen, ob ein Wert ein boolescher Wert ist") + + ((sdp-not not) (boolean -> boolean) + "booleschen Wert negieren") + + (boolean=? (boolean boolean -> boolean) + "Booleans auf Gleichheit testen") + + (true? (any -> boolean) + "feststellen, ob ein Wert #t ist") + (false? (any -> boolean) + "feststellen, ob ein Wert #f ist")) + + ("Listen" + (empty list "die leere Liste") + ((sdp-cons cons) (%a (list-of %a) -> (list-of %a)) + "erzeuge ein Cons aus Element und Liste") + (cons? (any -> boolean) + "feststellen, ob ein Wert ein Cons ist") + (empty? (any -> boolean) + "feststellen, ob ein Wert die leere Liste ist") + + (first ((list-of %a) -> %a) + "erstes Element eines Cons extrahieren") + (rest ((list-of %a) -> (list-of %a)) + "Rest eines Cons extrahieren") + + (list (%a ... -> (list-of %a)) + "Liste aus den Argumenten konstruieren") + + (length ((list-of %a) -> natural) + "Länge einer Liste berechnen") + + (filter ((%a -> boolean) (list-of %a) -> (list-of %a)) + "Alle Elemente einer Liste extrahieren, für welche die Funktion #t liefert.") + + (fold (%b (%a %b -> %b) (list-of %a) -> %b) + "Liste einfalten.") + + + ((sdp-append append) ((list-of %a) ... -> (list-of %a)) + "mehrere Listen aneinanderhängen") + + (list-ref ((list-of %a) natural -> %a) + "das Listenelement an der gegebenen Position extrahieren") + + (reverse ((list-of %a) -> (list-of %a)) + "Liste in umgekehrte Reihenfolge bringen")) + + ;; #### Zeichen sollten noch dazu, Vektoren wahrscheinlich auch + + ("Zeichenketten" + (string? (any -> boolean) + "feststellen, ob ein Wert eine Zeichenkette ist") + + (string=? (string string string ... -> boolean) + "Zeichenketten auf Gleichheit testen") + (string boolean) + "Zeichenketten lexikografisch auf kleiner-als testen") + (string>? (string string string ... -> boolean) + "Zeichenketten lexikografisch auf größer-als testen") + (string<=? (string string string ... -> boolean) + "Zeichenketten lexikografisch auf kleiner-gleich testen") + (string>=? (string string string ... -> boolean) + "Zeichenketten lexikografisch auf größer-gleich testen") + + (string-append (string string ... -> string) + "Hängt Zeichenketten zu einer Zeichenkette zusammen") + + (strings-list->string ((list string) -> string) + "Eine Liste von Zeichenketten in eine Zeichenkette umwandeln") + + (string->strings-list (string -> (list string)) + "Eine Zeichenkette in eine Liste von Zeichenketten mit einzelnen Zeichen umwandeln") + + (string-length (string -> natural) + "Liefert Länge einer Zeichenkette")) + + ("Symbole" + (symbol? (any -> boolean) + "feststellen, ob ein Wert ein Symbol ist") + (symbol=? (symbol symbol -> boolean) + "Sind zwei Symbole gleich?") + (symbol->string (symbol -> string) + "Symbol in Zeichenkette umwandeln") + (string->symbol (string -> symbol) + "Zeichenkette in Symbol umwandeln")) + + ("Verschiedenes" + (equal? (%a %b -> boolean) + "zwei Werte auf Gleichheit testen") + (eq? (%a %b -> boolean) + "zwei Werte auf Selbheit testen") + ((sdp-write-string write-string) (string -> unspecific) + "Zeichenkette in REPL ausgeben") + (write-newline (-> unspecific) + "Zeilenumbruch ausgeben") + (violation (string -> unspecific) + "Programmm mit Fehlermeldung abbrechen") + + (map ((%a -> %b) (list %a) -> (list %b)) + "Funktion auf alle Elemente einer Liste anwenden, Liste der Resultate berechnen") + (for-each ((%a -> %b) (list %a) -> unspecific) + "Funktion von vorn nach hinten auf alle Elemente einer Liste anwenden") + (apply (function (list %a) -> %b) + "Funktion auf Liste ihrer Argumente anwenden") + (read (-> any) + "Externe Repräsentation eines Werts in der REPL einlesen und den zugehörigen Wert liefern"))) + +(define real-cons + (procedure-rename + (lambda (f r) + (when (and (not (null? r)) + (not (pair? r))) + (raise + (make-exn:fail:contract + (string->immutable-string + (format "Zweites Argument zu cons ist keine Liste, sondern ~e" r)) + (current-continuation-marks)))) + (cons f r)) + 'cons)) + +(define-syntax sdp-cons + (let () + ;; make it work with match + (define-struct cons-info () + #:super struct:struct-info + #:property + prop:procedure + (lambda (_ stx) + (syntax-case stx () + ((self . args) (syntax/loc stx (real-cons . args))) + (else (syntax/loc stx real-cons))))) + (make-cons-info (lambda () + (list #f + #'real-cons + #'cons? + (list #'cdr #'car) + '(#f #f) + #f))))) + +(define (first l) + (when (not (pair? l)) + (raise + (make-exn:fail:contract + (string->immutable-string + (format "Argument zu first kein Cons, sondern ~e" l)) + (current-continuation-marks)))) + (car l)) + +(define (rest l) + (when (not (pair? l)) + (raise + (make-exn:fail:contract + (string->immutable-string + (format "Argument zu rest kein Cons, sondern ~e" l)) + (current-continuation-marks)))) + (cdr l)) + +(define empty '()) + +(define (empty? obj) + (null? obj)) + +(define (cons? obj) + (pair? obj)) + +(define-teach sdp append + (lambda args + (let loop ((args args) + (seen-rev '())) + (when (not (null? args)) + (let ((arg (car args))) + (when (and (not (null? arg)) + (not (pair? arg))) + (raise + (make-exn:fail:contract + (string->immutable-string + (format "Erstes Argument zu append keine Liste, sondern ~e; restliche Argumente:~a" + arg + (apply string-append + (map (lambda (arg) + (format " ~e" arg)) + (append (reverse seen-rev) + (list '<...>) + (cdr args)))))) + (current-continuation-marks)))) + (loop (cdr args) + (cons arg seen-rev))))) + + + (apply append args))) + +(define fold + (lambda (unit combine lis) + (cond + ((empty? lis) unit) + ((pair? lis) + (combine (first lis) + (fold unit combine (rest lis)))) + (else + (raise + (make-exn:fail:contract + (string->immutable-string + (format "Drittes Argument zu fold keine Liste, sondern ~e; andere Argumente: ~e ~e" + lis + unit combine)) + (current-continuation-marks))))))) + +(define filter + (lambda (p? lis) + (when (not (procedure? p?)) + (raise + (make-exn:fail:contract + (string->immutable-string + (format "Erstes Argument zu filter keine Funktion, sondern ~e" p?)) + (current-continuation-marks)))) + (cond + ((empty? lis) '()) + ((pair? lis) + (if (p? (first lis)) + (cons (first lis) + (filter p? (rest lis))) + (filter p? (rest lis)))) + (else + (raise + (make-exn:fail:contract + (string->immutable-string + (format "Zweites Argument zu filter keine Liste, sondern ~e" + lis)) + (current-continuation-marks))))))) + +;; This is copied from collects/lang/private/beginner-funs.rkt +;; Test-suite support (require is really an effect +;; to make sure that it's loaded) +(require deinprogramm/test-suite) + + +(define-for-syntax (raise-sdp-syntax-error form msg . exprs) + + (define (expr->form expr) + (let ((sexpr (syntax->datum expr))) + (cond + ((identifier? expr) sexpr) + ((syntax->list expr) + => (lambda (lis) + (expr->form (car lis)))) + (else #f)))) + + (let ((form + (or form + (if (pair? exprs) + (expr->form (car exprs)) + #f)))) + (raise + (exn:fail:syntax (if form + (string-append (format "~a" form) ": " msg) + msg) + (current-continuation-marks) + exprs)))) + +(define-for-syntax (binding-in-this-module? b) + (and (list? b) + (module-path-index? (car b)) + (let-values (((path base) (module-path-index-split (car b)))) + (and (not path) (not base))))) + +(define-for-syntax (transform-sdp-define stx mutable?) + (syntax-case stx () + ((sdp-define) + (raise-sdp-syntax-error + #f "Definition ohne Operanden" stx)) + ((sdp-define v) + (raise-sdp-syntax-error + #f "Definition erwartet zwei Operanden, nicht einen" stx)) + ((sdp-define var expr) + (begin + (check-for-id! + (syntax var) + "Der erste Operand der Definition ist kein Name") + + (let ((binding (identifier-binding (syntax var)))) + (when binding + (if (binding-in-this-module? binding) + (raise-sdp-syntax-error + #f + "Zweite Definition für denselben Namen" + stx) + (raise-sdp-syntax-error + #f + "Dieser Name gehört einer eingebauten Funktion und kann nicht erneut definiert werden" (syntax var))))) + (if mutable? + (with-syntax + ((dummy-def (stepper-syntax-property + (syntax (define dummy (lambda () (set! var 'dummy)))) + 'stepper-skip-completely + #t))) + (syntax/loc stx + (begin + dummy-def + (define var expr)))) + (syntax/loc stx (define var expr))))) + ((sdp-define v e1 e2 e3 ...) + (raise-sdp-syntax-error + #f "Definition mit mehr als zwei Operanden" stx)))) + +(define-syntax (sdp-define stx) + (transform-sdp-define stx #f)) + +(define-syntax (sdp-advanced-define stx) + (transform-sdp-define stx #t)) + +(define-for-syntax (check-body-definitions bodies) + (let ((pairs + (map (lambda (stx) + ;; want to be able to shadow global definitions + (syntax-case stx (sdp-define) + ((sdp-define) + (raise-sdp-syntax-error + #f "Definition ohne Operanden" stx)) + ((sdp-define v) + (raise-sdp-syntax-error + #f "Definition erwartet zwei Operanden, nicht einen" stx)) + ((sdp-define var expr) + (begin + (check-for-id! + (syntax var) + "Der erste Operand der Definition ist kein Name") + (cons #'var (syntax/loc stx (define var expr))))) + ((sdp-define v e1 e2 e3 ...) + (raise-sdp-syntax-error + #f "Definition mit mehr als zwei Operanden" stx)))) + bodies))) + (let loop ((pairs pairs)) + (when (pair? pairs) + (let ((id (caar pairs))) + (cond + ((memf (lambda (p) + (bound-identifier=? id (car p))) + (cdr pairs)) + => (lambda (rest) + (raise-sdp-syntax-error + #f + "Zweite Definition für denselben Namen" + (cdar rest))))) + (loop (cdr pairs))))) + (map cdr pairs))) + +(define-syntax (sdp-let stx) + (syntax-case stx () + ((sdp-let ((var expr) ...) body0 ... body) + (begin + (check-for-id-list! + (syntax->list (syntax (var ...))) + "Kein Name in `let-Bindung") + (with-syntax (((body0 ...) (check-body-definitions (syntax->list #'(body0 ...))))) + (syntax/loc stx ((lambda (var ...) body0 ... body) expr ...))))) + ((sdp-let expr ...) + (raise-sdp-syntax-error + #f "`let'-Ausdruck erwartet eine Liste von Bindungen (Paare aus Name und Ausdruck) und einen Rumpf" stx)))) + +(define-syntax (sdp-let* stx) + (syntax-case stx () + ((sdp-let* () body0 ... body) + (syntax/loc stx (let () body0 ... body))) + ((sdp-let* ((var1 expr1) (var2 expr2) ...) body0 ... body) + (begin + (check-for-id! + (syntax var1) + "Kein Name in `let*'-Bindung") + (with-syntax (((body0 ...) (check-body-definitions (syntax->list #'(body0 ...))))) + (syntax/loc stx ((lambda (var1) + (sdp-let* ((var2 expr2) ...) body0 ... body)) + expr1))))) + ((sdp-let* expr ...) + (raise-sdp-syntax-error + #f "`let*'-Ausdruck erwartet eine Liste von Bindungen (Paare aus Name und Ausdruck) und einen Rumpf" stx)))) + +(define-syntax (sdp-letrec stx) + (syntax-case stx () + ((sdp-letrec ((var expr) ...) body0 ... body) + (begin + (check-for-id-list! + (syntax->list (syntax (var ...))) + "Kein Name in letrec-Bindung") + (with-syntax (((body0 ...) (check-body-definitions (syntax->list #'(body0 ...))))) + (syntax/loc stx (letrec ((var expr) ...) body0 ... body))))) + ((sdp-letrec expr ...) + (raise-sdp-syntax-error + #f "`letrec''-Ausdruck erwartet eine Liste von Bindungen (Paare aus Name und Ausdruck) und einen Rumpf" stx)))) + +(define-syntax (sdp-lambda stx) + (syntax-case stx () + ((sdp-lambda (var ...) body0 ... body) + (begin + (check-for-id-list! + (syntax->list (syntax (var ...))) + "Kein Name als Parameter der Abstraktion") + (with-syntax (((body0 ...) (check-body-definitions (syntax->list #'(body0 ...))))) + (syntax/loc stx (lambda (var ...) body0 ... body))))) + ((sdp-lambda var body ...) + (identifier? (syntax var)) + (raise-sdp-syntax-error + #f "Um die Parameter einer Abstraktion gehören Klammern" (syntax var))) + ((sdp-lambda var ...) + (raise-sdp-syntax-error + #f "Fehlerhafte Abstraktion" stx)))) + +(define-syntax (sdp-advanced-lambda stx) + (syntax-case stx () + ((sdp-lambda (var ...) body) + (begin + (check-for-id-list! + (syntax->list (syntax (var ...))) + "Kein Name als Parameter der Abstraktion") + (syntax/loc stx (lambda (var ...) body)))) + ((sdp-lambda (var ... . rest) body0 ... body) + (begin + (check-for-id-list! + (syntax->list (syntax (var ...))) + "Kein Name als Parameter der Abstraktion") + (unless (null? (syntax->datum #'rest)) + (check-for-id! + (syntax rest) + "Kein Name als Restlisten-Parameter der Abstraktion")) + (with-syntax (((body0 ...) (check-body-definitions (syntax->list #'(body0 ...))))) + (syntax/loc stx (lambda (var ... . rest) body0 ... body))))) + ((sdp-lambda var ...) + (raise-sdp-syntax-error + #f "Fehlerhafte Abstraktion" stx)))) + +(define-syntax (sdp-begin stx) + (syntax-case stx () + ((sdp-begin) + (raise-sdp-syntax-error + #f "`begin`-Ausdruck braucht mindestens einen Operanden" stx)) + ((sdp-begin expr1 expr2 ...) + (syntax/loc stx (begin expr1 expr2 ...))))) + +(define-for-syntax (local-expand-for-error stx ctx stops) + ;; This function should only be called in an 'expression + ;; context. In case we mess up, avoid bogus error messages. + (when (memq (syntax-local-context) '(expression)) + (local-expand stx ctx stops))) + +(define-for-syntax (ensure-expression stx k) + (if (memq (syntax-local-context) '(expression)) + (k) + (stepper-syntax-property #`(begin0 #,stx) 'stepper-skipto skipto/second))) + +;; A consistent pattern for stepper-skipto: +(define-for-syntax (stepper-ignore-checker stx) + (stepper-syntax-property stx 'stepper-skipto '(syntax-e cdr syntax-e cdr car))) + +;; Raise a syntax error: +(define-for-syntax (teach-syntax-error form stx detail msg . args) + (let ([form (if (eq? form '|function call|) ; #### + form + #f)] ; extract name from stx + [msg (apply format msg args)]) + (if detail + (raise-sdp-syntax-error form msg stx detail) + (raise-sdp-syntax-error form msg stx)))) + +;; The syntax error when a form's name doesn't follow a "(" +(define-for-syntax (bad-use-error name stx) + (teach-syntax-error + name + stx + #f + "`~a' wurde an einer Stelle gefunden, die keiner offenen Klammer folgt" + name)) + +;; Use for messages "expected ..., found " +(define-for-syntax (something-else v) + (let ([v (syntax-e v)]) + (cond + [(number? v) "eine Zahl"] + [(string? v) "eine Zeichenkette"] + [else "etwas anderes"]))) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; cond +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-syntax (sdp-cond stx) + (ensure-expression + stx + (lambda () + (syntax-case stx () + [(_) + (teach-syntax-error + 'cond + stx + #f + "Bedingung und ein Ausdruck nach `cond' erwartet, aber da ist nichts")] + [(_ clause ...) + (let* ([clauses (syntax->list (syntax (clause ...)))] + [check-preceding-exprs + (lambda (stop-before) + (let/ec k + (for-each (lambda (clause) + (if (eq? clause stop-before) + (k #t) + (syntax-case clause () + [(question body0 ... answer) + (begin + (unless (and (identifier? (syntax question)) + (free-identifier=? (syntax question) #'sdp-else)) + (local-expand-for-error (syntax question) 'expression null)) + (local-expand-for-error #'(let () body0 ... answer) 'expression null))]))) + clauses)))]) + (let ([checked-clauses + (map + (lambda (clause) + (syntax-case clause (sdp-else) + [(sdp-else body0 ... answer) + (let ([lpos (memq clause clauses)]) + (when (not (null? (cdr lpos))) + (teach-syntax-error + 'cond + stx + clause + "`else'-Bedingung gefunden, die nicht am Ende des `cond'-Ausdrucks steht")) + (with-syntax ([(body0 ...) (check-body-definitions (syntax->list #'(body0 ...)))] + [new-test (stepper-syntax-property (syntax #t) 'stepper-else #t)]) + (syntax/loc clause (new-test body0 ... answer))))] + [(question body0 ... answer) + (begin + (with-syntax ([(body0 ...) (check-body-definitions (syntax->list #'(body0 ...)))] + [verified (stepper-ignore-checker (syntax (verify-boolean question 'cond)))]) + (syntax/loc clause (verified body0 ... answer))))] + [() + (check-preceding-exprs clause) + (teach-syntax-error + 'cond + stx + clause + "Bedingung und Ausdruck in Zweig erwartet, aber Zweig leer")] + [(question?) + (check-preceding-exprs clause) + (teach-syntax-error + 'cond + stx + clause + "Zweig mit Bedingung und Ausdruck erwartet, aber Zweig enthält nur eine Form")] + [_else + (teach-syntax-error + 'cond + stx + clause + "Zweig mit Bedingung und Ausdruck erwartet, aber ~a gefunden" + (something-else clause))])) + clauses)]) + ;; Add `else' clause for error (always): + (let ([clauses (append checked-clauses + (list + (with-syntax ([error-call (syntax/loc stx (error 'cond "alle Bedingungen ergaben #f"))]) + (syntax [else error-call]))))]) + (with-syntax ([clauses clauses]) + (syntax/loc stx (cond . clauses))))))] + [_else (bad-use-error 'cond stx)])))) + +(define-syntax sdp-else + (make-set!-transformer + (lambda (stx) + (define (bad expr) + (teach-syntax-error + 'else + expr + #f + "hier nicht erlaubt, weil kein Bedingung in `cond'-Zweig")) + (syntax-case stx (set! x) + [(set! e expr) (bad #'e)] + [(e . expr) (bad #'e)] + [e (bad stx)])))) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; if +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-syntax (sdp-if stx) + (ensure-expression + stx + (lambda () + (syntax-case stx () + [(_ test then else) + (with-syntax ([new-test (stepper-ignore-checker (syntax (verify-boolean test 'if)))]) + (syntax/loc stx + (if new-test + then + else)))] + [(_ . rest) + (let ([n (length (syntax->list (syntax rest)))]) + (teach-syntax-error + 'if + stx + #f + "Bedingung und zwei Ausdrücke erwartet, aber ~a Form~a gefunden" + (if (zero? n) "keine" n) + (if (= n 1) "" "en")))] + [_else (bad-use-error 'if stx)])))) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; or, and +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-syntaxes (sdp-or sdp-and) + (let ([mk + (lambda (where) + (let ([stepper-tag (case where + [(or) 'comes-from-or] + [(and) 'comes-from-and])]) + (with-syntax ([swhere where]) + (lambda (stx) + (ensure-expression + stx + (lambda () + (syntax-case stx () + [(_ . clauses) + (let ([n (length (syntax->list (syntax clauses)))]) + (let loop ([clauses-consumed 0] + [remaining (syntax->list #`clauses)]) + (if (null? remaining) + (case where + [(or) #`#f] + [(and) #`#t]) + (stepper-syntax-property + (stepper-syntax-property + (quasisyntax/loc + stx + (if #,(stepper-ignore-checker (quasisyntax/loc stx (verify-boolean #,(car remaining) 'swhere))) + #,@(case where + [(or) #`(#t + #,(loop (+ clauses-consumed 1) (cdr remaining)))] + [(and) #`(#,(loop (+ clauses-consumed 1) (cdr remaining)) + #f)]))) + 'stepper-hint + stepper-tag) + 'stepper-and/or-clauses-consumed + clauses-consumed))))] + [_else (bad-use-error where stx)])))))))]) + (values (mk 'or) (mk 'and)))) + +;; verify-boolean is inserted to check for boolean results: +(define (verify-boolean b where) + (if (or (eq? b #t) (eq? b #f)) + b + (raise + (make-exn:fail:contract + (string->immutable-string + (format "~a: Testresultat ist nicht boolesch: ~e" where b)) + (current-continuation-marks))))) + +(define-teach sdp not + (lambda (b) + (verify-boolean b 'not) + (not b))) + +(define (boolean=? a b) + (verify-boolean a 'boolean=?) + (verify-boolean b 'boolean=?) + (eq? a b)) + +(define (verify-symbol b where) + (if (symbol? b) + b + (raise + (make-exn:fail:contract + (string->immutable-string + (format "~a: Wert ist kein Symbol: ~e" where b)) + (current-continuation-marks))))) + +(define (symbol=? a b) + (verify-symbol a 'symbol=?) + (verify-symbol b 'symbol=?) + (eq? a b)) + +(define-syntax (sdp-app stx) + (define (raise-operator-error no-op expr) + (raise-sdp-syntax-error #f + (format "Operator darf ~a sein, ist aber ~s" no-op (syntax->datum expr)) + expr)) + (syntax-case stx () + ((_) + (raise-sdp-syntax-error + #f "Zusammengesetzte Form ohne Operator" (syntax/loc stx ()))) + ((_ datum1 datum2 ...) + (number? (syntax->datum #'datum1)) + (raise-operator-error "keine Zahl" #'datum1)) + ((_ datum1 datum2 ...) + (boolean? (syntax->datum #'datum1)) + (raise-operator-error "kein boolesches Literal" #'datum1)) + ((_ datum1 datum2 ...) + (string? (syntax->datum #'datum1)) + (raise-operator-error "keine Zeichenkette" #'datum1)) + ((_ datum1 datum2 ...) + (char? (syntax->datum #'datum1)) + (raise-operator-error "kein Zeichen" #'datum1)) + ((_ datum1 datum2 ...) + (syntax/loc stx (#%app datum1 datum2 ...))))) + +(define (top/check-defined id) + (namespace-variable-value (syntax-e id) #t (lambda () (raise-not-bound-error id)))) + +(define-syntax (sdp-top stx) + (syntax-case stx () + ((_ . id) + ;; If we're in a module, we'll need to check that the name + ;; is bound.... + (if (not (identifier-binding #'id)) + (if (syntax-source-module #'id) + ;; ... but it might be defined later in the module, so + ;; delay the check. + (stepper-ignore-checker + (syntax/loc stx (#%app values (sdp-top-continue id)))) + ;; identifier-finding only returns useful information when inside a module. + ;; At the top-level we need to do the check at runtime. Also, note that at + ;; the top level there is no need for stepper annotations + (syntax/loc stx (#%app top/check-defined #'id))) + + (syntax/loc stx (#%top . id)))))) + +(define-syntax (sdp-top-continue stx) + (syntax-case stx () + [(_ id) + ;; If there's still no binding, it's an "unknown name" error. + (if (not (identifier-binding #'id)) + ;; If there's still no binding, it's an "unknown name" error. + (raise-not-bound-error #'id) + + ;; Don't use #%top here; id might have become bound to something + ;; that isn't a value. + #'id)])) + +(define-teach sdp write-string + (lambda (s) + (when (not (string? s)) + (error "Argument von write-string ist keine Zeichenkette")) + (display s))) + +(define (write-newline) + (newline)) + +(define (violation text) + (error text)) + +(define (string->strings-list s) + (map (lambda (c) (make-string 1 c)) (string->list s))) + +(define (strings-list->string l) + (if (null? l) + "" + (string-append (car l) (strings-list->string (cdr l))))) + +(define integer (signature/arbitrary arbitrary-integer integer (predicate integer?))) +(define number (signature/arbitrary arbitrary-real number (predicate number?))) +(define rational (signature/arbitrary arbitrary-rational rational (predicate rational?))) +(define real (signature/arbitrary arbitrary-real real (predicate real?))) + +(define (natural? x) + (and (integer? x) + (not (negative? x)))) + +(define natural (signature/arbitrary arbitrary-natural natural (predicate natural?))) + +(define boolean (signature/arbitrary arbitrary-boolean boolean (predicate boolean?))) + +(define (true? x) + (eq? x #t)) + +(define (false? x) + (eq? x #f)) + +(define true (signature truen (one-of #t))) +(define false (signature false (one-of #f))) + +(define string (signature/arbitrary arbitrary-printable-ascii-string string (predicate string?))) +(define symbol (signature/arbitrary arbitrary-symbol symbol (predicate symbol?))) +(define empty-list (signature empty-list (one-of empty))) + +(define unspecific (signature unspecific %unspecific)) +(define any (signature any %any)) + +;; aus collects/lang/private/teach.rkt + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; dots (.. and ... and .... and ..... and ......) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Syntax Identifier -> Expression +;; Produces an expression which raises an error reporting unfinished code. +(define-for-syntax (dots-error stx name) + (quasisyntax/loc stx + (error (quote (unsyntax name)) + "Fertiger Ausdruck erwartet, aber da sind noch Ellipsen"))) + +;; Expression -> Expression +;; Transforms unfinished code (... and the like) to code +;; raising an appropriate error. +(define-syntax sdp-dots + (make-set!-transformer + (lambda (stx) + (syntax-case stx (set!) + [(set! form expr) (dots-error stx (syntax form))] + [(form . rest) (dots-error stx (syntax form))] + [form (dots-error stx stx)])))) + +(define-syntaxes (sdp-set! sdp-set!-continue) + (let ((proc + (lambda (continuing?) + (lambda (stx) + (ensure-expression + stx + (lambda () + (syntax-case stx () + ((_ id expr) + (identifier? (syntax id)) + (begin + ;; Check that id isn't syntax, and not lexical. + ((with-handlers ((exn:fail? (lambda (exn) void))) + ;; First try syntax: + ;; If it's a transformer binding, then it can take care of itself... + (if (set!-transformer? (syntax-local-value (syntax id))) + void ;; no lex check wanted + (lambda () + (raise-sdp-syntax-error + #f + "Nach set! wird eine gebundene Variable erwartet, aber da ist ein Schlüsselwort." + stx))))) + ;; If we're in a module, we'd like to check here whether + ;; the identier is bound, but we need to delay that check + ;; in case the id is defined later in the module. So only + ;; do this in continuing mode: + (when continuing? + (when (and (not (identifier-binding #'id)) + (syntax-source-module #'id)) + (raise-sdp-syntax-error #f "Ungebundene Variable" #'id))) + (if continuing? + (syntax/loc stx (set! id expr)) + (stepper-ignore-checker (syntax/loc stx (#%app values (sdp-set!-continue id expr))))))) + ((_ id expr) + (raise-sdp-syntax-error + #f + "Nach set! wird eine Variable aber da ist etwas anderes." + #'id)) + ((_ id) + (raise-sdp-syntax-error + #f + "Nach set! wird eine Variable und ein Ausdruck erwartet - der Ausdruck fehlt." + stx)) + ((_) + (raise-sdp-syntax-error + #f + "Nach set! wird eine Variable und ein Ausdruck erwartet, aber da ist nichts." + stx)) + (_else + (raise-sdp-syntax-error + #f + "Inkorrekter set!-Ausdruck." + stx))))))))) + (values (proc #f) + (proc #t)))) + +; QuickCheck + +(define-syntax (for-all stx) + (syntax-case stx () + ((_ (?clause ...) ?body) + (with-syntax ((((?id ?arb) ...) + (map (lambda (pr) + (syntax-case pr () + ((?id ?signature) + (identifier? #'?id) + (with-syntax ((?error-call + (syntax/loc #'?signature (error "Signatur hat keinen Generator")))) + #'(?id + (or (signature-arbitrary (signature ?signature)) + ?error-call)))) + (_ + (raise-sdp-syntax-error #f "inkorrekte `for-all'-Klausel - sollte die Form (id contr) haben" + pr)))) + (syntax->list #'(?clause ...))))) + + (stepper-syntax-property #'(quickcheck:property + ((?id ?arb) ...) ?body) + 'stepper-skip-completely + #t))) + ((_ ?something ?body) + (raise-sdp-syntax-error #f "keine Klauseln der Form (id contr)" + stx)) + ((_ ?thing1 ?thing2 ?thing3 ?things ...) + (raise-sdp-syntax-error #f "zuviele Operanden" + stx)))) + +(define-syntax (check-property stx) + (unless (memq (syntax-local-context) '(module top-level)) + (raise-sdp-syntax-error + #f "`check-property' muss ganz außen stehen" stx)) + (syntax-case stx () + ((_ ?prop) + (stepper-syntax-property + (check-expect-maker stx #'check-property-error #'?prop '() + 'comes-from-check-property) + 'stepper-replace + #'#t)) + (_ (raise-sdp-syntax-error #f "`check-property' erwartet einen einzelnen Operanden" + stx)))) + +(define (check-property-error test src-info test-info) + (let ((info (send test-info get-info))) + (send info add-check) + (with-handlers ((exn:fail? + (lambda (e) + (send info property-error e src-info) + (raise e)))) + (call-with-values + (lambda () + (with-handlers + ((exn:assertion-violation? + (lambda (e) + ;; minor kludge to produce comprehensible error message + (if (eq? (exn:assertion-violation-who e) 'coerce->result-generator) + (raise (make-exn:fail (string-append "Wert muß Eigenschaft oder boolesch sein: " + ((error-value->string-handler) + (car (exn:assertion-violation-irritants e)) + 100)) + (exn-continuation-marks e))) + (raise e))))) + (quickcheck-results (test)))) + (lambda (ntest stamps result) + (if (check-result? result) + (begin + (send info property-failed result src-info) + #f) + #t)))))) + +(define (expect v1 v2) + (quickcheck:property () (teach-equal? v1 v2))) + +(define (ensure-real who n val) + (unless (real? val) + (raise + (make-exn:fail:contract + (string->immutable-string + (format "~a Argument ~e zu `~a' keine reelle Zahl." n val who)) + (current-continuation-marks))))) + +(define (expect-within v1 v2 epsilon) + (ensure-real 'expect-within "Drittes" epsilon) + (quickcheck:property () (beginner-equal~? v1 v2 epsilon))) + +(define (expect-range val min max) + (ensure-real 'expect-range "Erstes" val) + (ensure-real 'expect-range "Zweites" min) + (ensure-real 'expect-range "Drittes" max) + (quickcheck:property () + (and (<= min val) + (<= val max)))) + +(define (expect-member-of val . candidates) + (quickcheck:property () + (ormap (lambda (cand) + (teach-equal? val cand)) + candidates))) + +(define property (signature (predicate (lambda (x) + (or (boolean? x) + (property? x)))))) + + +(define-syntax (match stx) + (syntax-parse stx + ((_ ?case:expr (?pattern0 ?body0:expr) (?pattern ?body:expr) ...) + (let () + (define (pattern-variables pat) + (syntax-case pat (empty sdp-cons list quote) + (empty '()) + (?var (identifier? #'?var) + (if (eq? (syntax->datum #'?var) '_) + '() + (list #'?var))) + (?lit (let ((d (syntax->datum #'?lit))) + (or (string? d) (number? d) (boolean? d))) + '()) + ('?lit '()) + ((sdp-cons ?pat1 ?pat2) + (append (pattern-variables #'?pat1) (pattern-variables #'?pat2))) + ((list) '()) + ((list ?pat0 ?pat ...) + (apply append (map pattern-variables (syntax->list #'(?pat0 ?pat ...))))) + ((?const ?pat ...) + (apply append (map pattern-variables (syntax->list #'(?pat ...))))))) + (define (check pat) + (let loop ((vars (pattern-variables pat))) + (when (pair? vars) + (let ((var (car vars))) + (when (memf (lambda (other-var) + (free-identifier=? var other-var)) + (cdr vars)) + (raise-sdp-syntax-error #f "Variable in match-Zweig kommt doppelt vor" + var)) + (loop (cdr vars)))))) + (for-each check (syntax->list #'(?pattern0 ?pattern ...))) + #'(let* ((val ?case) + (nomatch (lambda () (match val (?pattern ?body) ...)))) + (match-helper val ?pattern0 ?body0 (nomatch))))) + ((_ ?case:expr) + (syntax/loc stx (error 'match "keiner der Zweige passte"))))) + + +(define (list-length=? lis n) + (cond + ((zero? n) (null? lis)) + ((null? lis) #f) + (else + (list-length=? (cdr lis) (- n 1))))) + +(define-syntax (match-helper stx) + (syntax-case stx () + ((_ ?id ?pattern0 ?body0 ?nomatch) + (syntax-case #'?pattern0 (empty cons list quote) + (empty + #'(if (null? ?id) + ?body0 + ?nomatch)) + (?var (identifier? #'?var) + (if (eq? (syntax->datum #'?var) '_) ; _ is magic + #'?body0 + #'(let ((?var ?id)) + ?body0))) + (?lit (let ((d (syntax->datum #'?lit))) + (or (string? d) (number? d) (boolean? d))) + #'(if (equal? ?id ?lit) + ?body0 + ?nomatch)) + ('?lit + #'(if (equal? ?id '?lit) + ?body0 + ?nomatch)) + ((cons ?pat1 ?pat2) + #'(if (pair? ?id) + (let ((f (first ?id)) + (r (rest ?id))) + (match-helper f ?pat1 + (match-helper r ?pat2 ?body0 ?nomatch) + ?nomatch)) + ?nomatch)) + ((list) + #'(if (null? ?id) + ?body0 + ?nomatch)) + ((list ?pat0 ?pat ...) + (let* ((pats (syntax->list #'(?pat0 ?pat ...))) + (cars (generate-temporaries pats)) + (cdrs (generate-temporaries pats))) + #`(if (and (pair? ?id) + (list-length=? ?id #,(length pats))) + #,(let recur ((ccdr #'?id) + (pats pats) + (cars cars) (cdrs cdrs)) + (if (null? pats) + #'?body0 + #`(let ((#,(car cars) (car #,ccdr)) + (#,(car cdrs) (cdr #,ccdr))) + (match-helper #,(car cars) #,(car pats) + #,(recur (car cdrs) (cdr pats) (cdr cars) (cdr cdrs)) + ?nomatch)))) + ?nomatch))) + ((?const ?pat ...) + (identifier? #'?const) + (let* ((fail (lambda () + (raise-sdp-syntax-error #f "Operator in match muss ein Record-Konstruktor sein" + #'?const))) + (v (syntax-local-value #'?const fail))) + (unless (struct-info? v) + (fail)) + + (apply + (lambda (_ _cons pred rev-selectors _mutators ?) + (let* ((pats (syntax->list #'(?pat ...))) + (selectors (reverse rev-selectors)) + (field-ids (generate-temporaries pats))) + (unless (= (length rev-selectors) (length pats)) + (raise-sdp-syntax-error #f "Die Anzahl der Felder im match stimmt nicht" stx)) + #`(if (#,pred ?id) + #,(let recur ((pats pats) + (selectors selectors) + (field-ids field-ids)) + (if (null? pats) + #'?body0 + #`(let ((#,(car field-ids) (#,(car selectors) ?id))) + (match-helper #,(car field-ids) #,(car pats) + #,(recur (cdr pats) (cdr selectors) (cdr field-ids)) + ?nomatch)))) + ?nomatch))) + (extract-struct-info v)))))))) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/private/rewrite-error-message.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/private/rewrite-error-message.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/private/rewrite-error-message.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/private/rewrite-error-message.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,183 @@ +#lang scheme/base + +;; Copied and adapted from htdp-lib + +(require mzlib/etc + mzlib/list + (for-syntax lang/private/firstorder + scheme/base)) + +(provide rewrite-contract-error-message + reraise-rewriten-lookup-error-message + get-rewriten-error-message + raise-not-bound-error + argcount-error-message) + +(define (reraise-rewriten-lookup-error-message e id was-in-app-position) + (let ([var-or-function (if was-in-app-position "Funktion" "Variable")]) + (raise-syntax-error + #f + (format "~a ist nicht definiert" var-or-function) + id))) + +(define (exn-needs-rewriting? exn) + (exn:fail:contract? exn)) + +(define (ensure-number n-or-str) + (if (string? n-or-str) (string->number n-or-str) n-or-str)) + +(define (plural-e n) + (if (> (ensure-number n) 1) "e" "")) + +(define (raise-not-bound-error id) + (if (syntax-property id 'was-in-app-position) + (raise-syntax-error + #f + "Funktion ist nicht definiert" + id) + (raise-syntax-error + #f + "Variable ist nicht definiert" + id))) + +(define (argcount-error-message name arity found [at-least #f]) + (define arity:n (ensure-number arity)) + (define found:n (ensure-number found)) + (define fn-is-large (> arity:n found:n)) + (format "~a erwartet ~a~a~a~a Argument~a, aber ~a~a gefunden" + (or name "") (if name ": " "") + (if at-least "mindestens " "") + (if (or (= arity:n 0) fn-is-large) "" "nur ") + (if (= arity:n 0) "kein" arity:n) (plural-e arity:n) + (if (and (not (= found:n 0)) fn-is-large) "nur " "") + (if (= found:n 0) "keins" found:n))) + +(define (format-enum conj l) + (if (= (length l) 2) + (format "~a ~a ~a" (car l) conj (cadr l)) + (apply string-append + (let loop ([l l]) + (cond + [(null? (cdr l)) l] + [(null? (cddr l)) + (list* (car l) ", " conj " " (loop (cdr l)))] + [else + (list* (car l) ", " (loop (cdr l)))]))))) + +(define (contract-to-desc ctc) + (with-handlers ([exn:fail:read? (lambda (exn) ctc)]) + (define s (read (open-input-string ctc))) + (let loop ([s s]) + (cond + [(not s) "#f"] + [(and (symbol? s) (regexp-match? #rx"[?]$" (symbol->string s))) + (case s + ((number?) "Zahl") + ((string?) "Zeichenkette") + (else + (define str (symbol->string s)) + (substring str 0 (sub1 (string-length str)))))] + [(null? s) "einen unmöglicher Wert"] + [(not (list? s)) ctc] ;; ??? + [(eq? 'or/c (car s)) + (format-enum "oder" (map loop (cdr s)))] + [(eq? 'and/c (car s)) + (string-append "einen Wert der " (format-enum "und" (map loop (cdr s))))] + [(eq? 'not/c (car s)) + (format "ein Wert der nicht ~a" (loop (cadr s)))] + [(and (eq? '>/c (car s)) (zero? (cadr s))) + "eine positive Zahl"] + [(and (eq? '=/c (car s)) (zero? (cadr s))) + "eine nicht-negative Zahl"] + [else ctc])))) + +(define (translate-pos pos) + (cond + ((string=? pos "1st") "erstes") + ((string=? pos "2nd") "zweites") + ((string=? pos "3rd") "drittes") + ((string=? pos "4th") "viertes") + ((string=? pos "5th") "fünftes") + ((string=? pos "6th") "sechstes") + ((string=? pos "7th") "siebtes") + ((string=? pos "8th") "achtes") + ((string=? pos "9th") "neuntes") + ((string=? pos "10th") "zehntes") + ((string=? pos "11th") "zehntes") + ((regexp-match #rx"^([0-9]+)th" pos) + => (lambda (lis) + (string-append (cadr lis) "."))) + (else pos))) + +(define (contract-error-message ctc given pos) + (define d (contract-to-desc ctc)) + (format "~a~a~a~a erwartet, ~a bekommen" + d + (if pos " als " "") + (if pos + (translate-pos pos) + "") + (if pos " Argument" "") + given)) + +(define (expects-a all one two) + (format "~a erwartet" two)) + +(define (rewrite-contract-error-message msg) + (define replacements + (list (list #rx"application: not a procedure;\n [^\n]*?\n given: ([^\n]*)(?:\n arguments[.][.][.]:(?: [[]none[]]|(?:\n [^\n]*)*))?" + (lambda (all one) + (format "Applikation: Funktion nach der öffnenden Klammer erwartet, aber ~a bekommen" one))) + (list #rx"([^\n]*): undefined;\n cannot reference an identifier before its definition" + (lambda (all one) (format "~a ist vor der Definition benutzt worden" one))) + (list #rx"expects argument of type (<([^>]+)>)" expects-a) + (list #rx"expected argument of type (<([^>]+)>)" expects-a) + (list #rx"expects type (<([^>]+)>)" expects-a) + (list #px"([^\n]*): arity mismatch;\n[^\n]*\n expected[^:]*: at least (\\d+)\n given[^:]*: (\\d+)(?:\n arguments[.][.][.]:(?:\n [^\n]*)*)?" + (lambda (all one two three) (argcount-error-message one two three #t))) + (list #px"([^\n]*): arity mismatch;\n[^\n]*\n expected[^:]*: (\\d+)\n given[^:]*: (\\d+)(?:\n arguments[.][.][.]:(?:\n [^\n]*)*)?" + (lambda (all one two three) (argcount-error-message one two three))) + (list #px"contract violation\n expected: (.*?)\n given: ([^\n]*)(?:\n argument position: ([^\n]*))?" + (lambda (all ctc given pos) (contract-error-message ctc given pos))) + (list #rx"^procedure " + (lambda (all) "")) + (list #rx", given: " + (lambda (all) ", bekommen ")) + (list #rx"; other arguments were:.*" + (lambda (all) "")) + (list #px"(?:\n other arguments[.][.][.]:(?:\n [^\n]*)*)" + (lambda (all) "")) + (list #rx"expects a (struct:)" + (lambda (all one) "erwartet ")) + (list #rx"list or cyclic list" + (lambda (all) "Liste")) + (list #rx"assignment disallowed;\n cannot set variable before its definition\n variable:" + (lambda (all) "Kann Variable nicht vor der Definition setzen:")) + (list #rx"^(.*): undefined;\n cannot use before initialization" + (λ (all one) (format "Lokale Variable vor ihrer Definition benutzt: ~a" one))) + (list #rx"division by zero" + (lambda (all) "durch 0 geteilt")) + ;; When do these show up? I see only `#' errors, currently. + (list (regexp-quote "#(struct:object:image% ...)") + (lambda (all) "ein Bild")) + (list (regexp-quote "#(struct:object:image-snip% ...)") + (lambda (all) "ein Bild")) + (list (regexp-quote "#(struct:object:cache-image-snip% ...)") + (lambda (all) "ein Bild")))) + (for/fold ([msg msg]) ([repl. replacements]) + (regexp-replace* (first repl.) msg (second repl.)))) + +(define (rewrite-misc-error-message msg) + (define replacements + (list + (list #rx"expected a `\\)` to close `\\(`" + (lambda (all) "zur offenen Klammer fehlt die geschlossene")))) + (for/fold ([msg msg]) ([repl. replacements]) + (regexp-replace* (first repl.) msg (second repl.)))) + +(define (get-rewriten-error-message exn) + (if (exn:fail:contract? exn) + (rewrite-contract-error-message (exn-message exn)) + (rewrite-misc-error-message (exn-message exn)))) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/private/sdp-langs.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/private/sdp-langs.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/private/sdp-langs.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/private/sdp-langs.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,1296 @@ +#lang scheme/base + +(require string-constants + framework + (prefix-in et: errortrace/stacktrace) + (prefix-in tr: trace/stacktrace) + mzlib/pretty + (prefix-in pc: mzlib/pconvert) + mzlib/file + mzlib/unit + mzlib/class + mzlib/list + racket/match + racket/path + (only-in racket/list add-between last) + racket/contract + mzlib/struct + mzlib/compile + drscheme/tool + mred + framework/private/bday + syntax/moddep + mrlib/cache-image-snip + compiler/embed + wxme/wxme + setup/dirs + setup/getinfo + setup/collects + + lang/stepper-language-interface + lang/debugger-language-interface + lang/run-teaching-program + lang/private/continuation-mark-key + deinprogramm/sdp/private/rewrite-error-message + + (only-in test-engine/scheme-gui make-formatter) + test-engine/scheme-tests + lang/private/tp-dialog + (lib "test-display.scm" "test-engine") + deinprogramm/signature/signature + lang/htdp-langs-interface + ) + + + (require mzlib/pconvert-prop) + + (require deinprogramm/sdp/private/convert-explicit) + + (require (only-in mrlib/syntax-browser render-syntax/snip)) + + (provide tool@) + + (define ellipses-cutoff 200) + + (define o (current-output-port)) + (define (oprintf . args) (apply fprintf o args)) + + (define generic-proc + (procedure-rename void '?)) + + ;; adapted from collects/drracket/private/main.rkt + (preferences:set-default 'drracket:deinprogramm:sdp:last-set-teachpacks/multi-lib + '() + (lambda (x) + (and (list? x) + (andmap (lambda (x) + (and (list? x) + (pair? x) + (eq? (car x) 'lib) + (andmap string? (cdr x)))) + x)))) + + + (define tool@ + (unit + (import drscheme:tool^) + (export drscheme:tool-exports^) + + (define drs-eventspace (current-eventspace)) + + ;; writing-style : {explicit, datum} + ;; tracing? : boolean + ;; teachpacks : (listof require-spec) + (define-struct (deinprogramm-lang-settings drscheme:language:simple-settings) + (writing-style tracing? teachpacks)) + (define deinprogramm-lang-settings->vector (make-->vector deinprogramm-lang-settings)) + (define deinprogramm-teachpacks-field-index + (+ (procedure-arity drscheme:language:simple-settings) 2)) + + (define image-string "") + + (define deinprogramm-language<%> + (interface () + get-module + get-language-position + get-sharing-printing + get-abbreviate-cons-as-list + get-allow-sharing? + get-use-function-output-syntax? + get-accept-quasiquote? + get-read-accept-dot)) + + ;; 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 printing-style writing-style super%) + (class* super% () + + (inherit get-sharing-printing get-abbreviate-cons-as-list) + + (define/override (default-settings) + (make-deinprogramm-lang-settings + #f + printing-style + 'repeating-decimal + (get-sharing-printing) + #t + 'none + writing-style + #f + (preferences:get 'drracket:deinprogramm:sdp:last-set-teachpacks/multi-lib))) + + (define/override (default-settings? s) + (and (not (drscheme:language:simple-settings-case-sensitive s)) + (eq? (drscheme:language:simple-settings-printing-style s) + printing-style) + (eq? (drscheme:language:simple-settings-fraction-style s) + 'repeating-decimal) + (eqv? (drscheme:language:simple-settings-show-sharing s) + (get-sharing-printing)) + (drscheme:language:simple-settings-insert-newlines s) + (eq? (drscheme:language:simple-settings-annotations s) + 'none) + (eq? writing-style (deinprogramm-lang-settings-writing-style s)) + (not (deinprogramm-lang-settings-tracing? s)) + (null? (deinprogramm-lang-settings-teachpacks s)))) + + (define/override (marshall-settings x) + (list (super marshall-settings x) + (deinprogramm-lang-settings-writing-style x) + (deinprogramm-lang-settings-tracing? x) + (deinprogramm-lang-settings-teachpacks x))) + + (define/override (unmarshall-settings x) + (if (and (list? x) + (= (length x) 4) + (symbol? (list-ref x 1)) ; #### + (boolean? (list-ref x 2)) + (list-of-require-specs? (list-ref x 3))) + (let ([drs-settings (super unmarshall-settings (first x))]) + (make-deinprogramm-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) + (cadddr x))) + (default-settings))) + + (define/private (list-of-require-specs? l) + (and (list? l) + (andmap (lambda (x) + (and (list? x) + (andmap (lambda (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)] + [scheme-test-module-name + ((current-module-name-resolver) '(lib "test-engine/scheme-tests.rkt") #f #f #t)] + [scheme-signature-module-name + ((current-module-name-resolver) '(lib "deinprogramm/signature/signature-german.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?)) + (ensure-drscheme-secrets-declared drs-namespace) + (namespace-attach-module drs-namespace ''drscheme-secrets) + (error-display-handler teaching-languages-error-display-handler) + (error-value->string-handler + (lambda (x y) (teaching-languages-error-value->string settings x y))) + (current-eval (add-annotation (deinprogramm-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? (preferences:get 'signatures:enable-checking?)) + (test-format (make-formatter (lambda (v o) + (render-value/format (if (procedure? v) + generic-proc + v) + settings o 40)))) + ))) + (super on-execute settings run-in-user-thread) + + ;; DeinProgramm addition, copied from language.rkt + (run-in-user-thread + (lambda () + (global-port-print-handler + (lambda (value port) + (let ([converted-value (simple-module-based-language-convert-value value settings)]) + (setup-printing-parameters + (lambda () + (parameterize ([pretty-print-columns 'infinity]) + (pretty-print converted-value port))) + settings + '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) + (parameterize ([pc:booleans-as-true/false #f] + [pc:abbreviate-cons-as-list (get-abbreviate-cons-as-list)] + [pretty-print-show-inexactness #t] + [pretty-print-exact-as-decimal #t] + [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) + (set-printing-parameters + settings + (lambda () + (simple-module-based-language-render-value/format value settings port width)))) + + (define/override (render-value value settings port) + (set-printing-parameters + settings + (lambda () + (simple-module-based-language-render-value/format value settings port 'infinity)))) + + (super-new))) + + ;; this inspector should be powerful enough to see + ;; any structure defined in the user's namespace + (define drscheme-inspector (current-inspector)) + + ;; FIXME: brittle, mimics drscheme-secrets + ;; as declared in lang/htdp-langs.rkt. + ;; Is it even needed for DeinProgramm langs? + ;; Only used by htdp/hangman teachpack. + (define (ensure-drscheme-secrets-declared drs-namespace) + (parameterize ((current-namespace drs-namespace)) + (define (declare) + (eval `(,#'module drscheme-secrets mzscheme + (provide drscheme-inspector) + (define drscheme-inspector ,drscheme-inspector))) + (namespace-require ''drscheme-secrets)) + (with-handlers ([exn:fail? (lambda (e) (declare))]) + ;; May have been declared by lang/htdp-langs tool, if loaded + (dynamic-require ''drscheme-secrets 'drscheme-inspector)) + (void))) + + + ;; { + ;; all this copied from collects/drracket/private/language.rkt + + ;; stepper-convert-value : TST settings -> TST + (define (stepper-convert-value value settings) + (define ((leave-snips-alone-hook sh) expr basic-convert sub-convert) + (if (or (is-a? expr snip%) + ;; FIXME: internal in language.rkt (to-snip-value? expr) + ) + expr + (sh expr basic-convert sub-convert))) + ;; mflatt: MINOR HACK - work around temporary + ;; print-convert problems + (define (stepper-print-convert v) + (or (and (procedure? v) (object-name v)) + (pc:print-convert v))) + + (case (drscheme:language:simple-settings-printing-style settings) + [(write) + (let ((v (convert-explicit value))) + (or (and (procedure? v) (object-name v)) + v))] + [(current-print) value] + [(constructor) + (parameterize + ([pc:constructor-style-printing #t] + [pc:show-sharing + (drscheme:language:simple-settings-show-sharing settings)] + [pc:current-print-convert-hook + (leave-snips-alone-hook (pc:current-print-convert-hook))]) + (stepper-print-convert value))] + [(quasiquote) + (parameterize + ([pc:constructor-style-printing #f] + [pc:show-sharing + (drscheme:language:simple-settings-show-sharing settings)] + [pc:current-print-convert-hook + (leave-snips-alone-hook (pc:current-print-convert-hook))]) + (stepper-print-convert value))] + [else (error "Internal stepper error: time to resync with simple-module-based-language-convert-value")])) + + ;; set-print-settings ; settings ( -> TST) -> TST + (define (set-print-settings language simple-settings thunk) + (if (method-in-interface? 'set-printing-parameters (object-interface language)) + (send language set-printing-parameters simple-settings thunk) + ;; assume that the current print-convert context is fine + ;; (error 'stepper-tool "language object does not contain set-printing-parameters method") + (thunk))) + + ;; simple-module-based-language-render-value/format : TST settings port (union #f (snip% -> void)) (union 'infinity number) -> void + (define (simple-module-based-language-render-value/format value settings port width) + (if (eq? (drscheme:language:simple-settings-printing-style settings) 'current-print) + (parameterize ([current-output-port port]) + ((current-print) value)) + (let ([converted-value (simple-module-based-language-convert-value value settings)]) + (setup-printing-parameters + (lambda () + (cond + [(drscheme:language:simple-settings-insert-newlines settings) + (if (number? width) + (parameterize ([pretty-print-columns width]) + (pretty-print converted-value port)) + (pretty-print converted-value port))] + [else + (parameterize ([pretty-print-columns 'infinity]) + (pretty-print converted-value port)) + (newline port)])) + settings + width)))) + + (define (procedure-output proc) + (cond + ((object-name proc) + => (lambda (name) + (string-append "#string name) ">"))) + (else "#"))) + + (define (signature-output proc) + (cond + ((signature-name proc) + => (lambda (name) + (string-append "#string name) ">"))) + (else "#"))) + + ;; setup-printing-parameters : (-> void) -> void + (define (setup-printing-parameters thunk settings width) + (let ([use-number-snip? + (lambda (x) + (and (number? x) + (exact? x) + (real? x) + (not (integer? x))))]) + (parameterize (;; these three handlers aren't used, but are set to override the user's settings + [pretty-print-print-line (lambda (line-number op old-line dest-columns) + (when (and (not (equal? line-number 0)) + (not (equal? dest-columns 'infinity))) + (newline op)) + 0)] + [pretty-print-pre-print-hook (lambda (val port) (void))] + [pretty-print-post-print-hook (lambda (val port) (void))] + + + [pretty-print-columns width] + [pretty-print-size-hook + (lambda (value display? port) + (cond + [(not (port-writes-special? port)) #f] + [(signature? value) (string-length (signature-output value))] + [(procedure? value) (string-length (procedure-output value))] + [(is-a? value snip%) 1] + [(use-number-snip? value) 1] + [(syntax? value) 1] + [(to-snip-value? value) 1] + [else #f]))] + [pretty-print-print-hook + (lambda (value display? port) + (cond + [(signature? value) + (write-special (signature-output value) port)] + [(procedure? value) + (write-special (procedure-output value) port)] + [(is-a? value snip%) + (write-special value port) + 1] + [(use-number-snip? value) + (write-special + (case (drscheme:language:simple-settings-fraction-style settings) + [(mixed-fraction) + (number-snip:make-fraction-snip value #f)] + [(mixed-fraction-e) + (number-snip:make-fraction-snip value #t)] + [(repeating-decimal) + (number-snip:make-repeating-decimal-snip value #f)] + [(repeating-decimal-e) + (number-snip:make-repeating-decimal-snip value #t)]) + port) + 1] + [(syntax? value) + (write-special (render-syntax/snip value) port)] + [else (write-special (value->snip value) port)]))] + [print-graph + ;; only turn on print-graph when using `write' printing + ;; style because the sharing is being taken care of + ;; by the print-convert sexp construction when using + ;; other printing styles. + (and (eq? (drscheme:language:simple-settings-printing-style settings) 'write) + (drscheme:language:simple-settings-show-sharing settings))]) + (thunk)))) + + ;; DeinProgramm changes in this procedure + ;; simple-module-based-language-convert-value : TST settings -> TST + (define (simple-module-based-language-convert-value value settings) + (case (drscheme:language:simple-settings-printing-style settings) + [(write) + ;; THIS IS THE CHANGE + (case (deinprogramm-lang-settings-writing-style settings) + [(explicit) (convert-explicit value)] + [(datum) value])] + [(current-print) value] + [(constructor) + (parameterize ([pc:constructor-style-printing #t] + [pc:show-sharing (drscheme:language:simple-settings-show-sharing settings)] + [pc:current-print-convert-hook (leave-snips-alone-hook (pc:current-print-convert-hook))]) + (pc:print-convert value))] + [(quasiquote) + (parameterize ([pc:constructor-style-printing #f] + [pc:show-sharing (drscheme:language:simple-settings-show-sharing settings)] + [pc:current-print-convert-hook (leave-snips-alone-hook (pc:current-print-convert-hook))]) + (pc:print-convert value))])) + + ;; leave-snips-alone-hook : any? (any? -> printable) any? -> printable + (define ((leave-snips-alone-hook sh) expr basic-convert sub-convert) + (if (is-a? expr snip%) + expr + (sh expr basic-convert sub-convert))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; snip/value extensions + ;; + + (define to-snips null) + (define-struct to-snip (predicate? >value)) + (define (add-snip-value predicate constructor) + (set! to-snips (cons (make-to-snip predicate constructor) to-snips))) + + (define (value->snip v) + (ormap (lambda (to-snip) (and ((to-snip-predicate? to-snip) v) + ((to-snip->value to-snip) v))) + to-snips)) + (define (to-snip-value? v) + (ormap (lambda (to-snip) ((to-snip-predicate? to-snip) v)) to-snips)) + + + ;; } + + ;; 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) + (let* ([parent (make-object vertical-panel% _parent)] + + [input-panel (instantiate group-box-panel% () + (parent parent) + (label (string-constant input-syntax)) + (alignment '(left center)))] + + [output-panel (instantiate group-box-panel% () + (parent parent) + (label (string-constant output-syntax)) + (alignment '(left center)))] + + [tp-group-box (instantiate group-box-panel% () + (label (string-constant teachpacks)) + (parent parent) + (alignment '(center top)))] + [tp-panel (new vertical-panel% + [parent tp-group-box] + [alignment '(center center)] + [stretchable-width #f] + [stretchable-height #f])] + + [case-sensitive (make-object check-box% + (string-constant case-sensitive-label) + input-panel + void)] + [output-style (make-object radio-box% + (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))) + output-panel + void)] + [writing-style (make-object radio-box% + "write-Ausgabe" + (list "explizit" + "Datum") + output-panel + void)] + [fraction-style + (make-object radio-box% (string-constant fraction-style) + (list (string-constant use-mixed-fractions) + (string-constant use-repeating-decimals)) + output-panel + void)] + [show-sharing #f] + [insert-newlines (make-object check-box% + (string-constant use-pretty-printer-label) + output-panel + void)] + + [tracing (new check-box% + (parent output-panel) + (label (string-constant tracing-enable-tracing)) + (callback void))] + + [tps '()]) + + (when allow-sharing-config? + (set! show-sharing + (instantiate 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) + + (case-lambda + [() + (make-deinprogramm-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 + (case (send writing-style get-selection) + [(0) 'explicit] + [(1) 'datum]) + (send tracing get-value) + tps)] + [(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] + [(write) 2] + [(print) 2]) + (case (drscheme:language:simple-settings-printing-style settings) + [(constructor) 0] + [(quasiquote) 0] + [(write) 1] + [(print) 1]))) + (send writing-style set-selection + (case (deinprogramm-lang-settings-writing-style settings) + [(explicit) 0] + [(datum) 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 (deinprogramm-lang-settings-teachpacks settings)) + (send tp-panel change-children (lambda (l) '())) + (if (null? tps) + (new message% + [parent tp-panel] + [label (string-constant teachpacks-none)]) + (for-each + (lambda (tp) (new message% + [parent tp-panel] + [label (format "~s" tp)])) + tps)) + (send tracing set-value (deinprogramm-lang-settings-tracing? settings)) + (void)]))) + + (define simple-deinprogramm-language% + ;; htdp-language<%> interface is here to make + ;; the "Racket | Disable Tests" menu item + ;; work for these languages + (class* drscheme:language:simple-module-based-language% (deinprogramm-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 #t) ;; #### should only be this in advanced mode + (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-deinprogramm-style-delta) style-delta) + + (super-instantiate () + (language-url "http://www.deinprogramm.de/sdp/")))) + + (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 (deinprogramm-lang-settings-teachpacks settings)) + + (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 " und " 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 " und " 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/private (tp-require->str tp) + (match tp + [`(lib ,x) + (define m (regexp-match #rx"teachpack/deinprogramm/sdp/(.*)$" x)) + (if m + (list-ref m 1) + (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 + (lambda (exe-name) + (create-embedding-executable + exe-name + #:modules `((#f ,program-filename)) + #:cmdline `("-l" + "scheme/base" + "-e" + ,(format "~s" `(#%require ',(filename->require-symbol program-filename)))) + #:src-filter + (lambda (path) (cannot-compile? path)) + #:get-extra-imports + (lambda (path cm) + (call-with-input-file path + (lambda (port) + (cond + [(is-wxme-stream? port) + (let-values ([(snip-class-names data-class-names) + (extract-used-classes port)]) + (list* + '(lib "wxme/read.ss") + '(lib "mred/mred.ss") + reader-module + (filter + values + (map (lambda (x) (string->lib-path x #t)) + (append + snip-class-names + data-class-names)))))] + [else + '()])))) + #:mred? #t)))))) + + (define/private (filename->require-symbol fn) + (let-values ([(base name dir) (split-path fn)]) + (string->symbol + (path->string + (path-replace-suffix name #""))))) + + (define/private (symbol-append x y) + (string->symbol + (string-append + (symbol->string x) + (symbol->string y)))) + + (inherit get-deinprogramm-style-delta) + (define/override (get-style-delta) + (get-deinprogramm-style-delta)) + + (inherit get-reader set-printing-parameters) + + (define/override (front-end/complete-program port settings) + (expand-teaching-program port + (get-reader) + (get-module) + (deinprogramm-lang-settings-teachpacks settings) + '#%deinprogramm)) + + (define/override (front-end/interaction port settings) + (let ([reader (get-reader)] ;; DeinProgramm addition: + ;; needed for test boxes; see + ;; the code in + ;; collects/drracket/private/language.rkt + [start? #t] + [done? #f]) + (λ () + (cond + [start? + (set! start? #f) + #'(#%plain-app reset-tests)] + [done? eof] + [else + (let ([ans (reader (object-name port) port)]) + (cond + [(eof-object? ans) + (set! done? #t) + #`(test)] + [else + ans]))])))) + + (define/augment (capability-value key) + (case key + [(drscheme:teachpack-menu-items) deinprogramm-teachpack-callbacks] + [(drscheme:special:insert-lambda) #f] + [else (inner (drscheme:language:get-capability-default key) + capability-value + key)])) + + (define deinprogramm-teachpack-callbacks + (drscheme:unit:make-teachpack-callbacks + (lambda (settings) + (map (lambda (x) (tp-require->str x)) (deinprogramm-lang-settings-teachpacks settings))) + (lambda (settings parent) + (define old-tps (deinprogramm-lang-settings-teachpacks settings)) + (define tp-dirs (list "deinprogramm/sdp")) + (define labels (list (string-constant teachpack-pre-installed))) + (define tp-syms '(deinprogramm-sdp-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))))) + + (preferences:set 'drracket:deinprogramm:sdp:last-set-teachpacks/multi-lib new-tps) + (make-deinprogramm-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) + (deinprogramm-lang-settings-writing-style settings) + (deinprogramm-lang-settings-tracing? settings) + new-tps)) + (lambda (settings name) + (let ([new-tps (filter (lambda (x) (not (equal? (tp-require->str x) name))) + (deinprogramm-lang-settings-teachpacks settings))]) + (preferences:set 'drracket:deinprogramm:sdp:last-set-teachpacks/multi-lib new-tps) + (make-deinprogramm-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) + (deinprogramm-lang-settings-writing-style settings) + (deinprogramm-lang-settings-tracing? settings) + new-tps))) + (lambda (settings) + (preferences:set 'drracket:deinprogramm:sdp:last-set-teachpacks/multi-lib '()) + (make-deinprogramm-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) + (deinprogramm-lang-settings-writing-style settings) + (deinprogramm-lang-settings-tracing? settings) + '())))) + + (inherit-field reader-module) + (define/override (get-reader-module) reader-module) + (define/override (get-metadata modname settings) + (define parsed-tps + (marshall-teachpack-settings + (deinprogramm-lang-settings-teachpacks settings))) + (string-append + ";; Die ersten drei Zeilen dieser Datei wurden von DrRacket eingefügt. Sie enthalten Metadaten\n" + ";; über die Sprachebene dieser Datei in einer Form, die DrRacket verarbeiten kann.\n" + (format "#reader~s~s\n" + reader-module + `((modname ,modname) + (read-case-sensitive ,(drscheme:language:simple-settings-case-sensitive settings)) + (teachpacks ,parsed-tps) + (deinprogramm-settings + ,(for/vector ([e (in-vector (deinprogramm-lang-settings->vector settings))] + [i (in-naturals)]) + (cond + [(= i deinprogramm-teachpacks-field-index) parsed-tps] + [else e]))))))) + + (inherit default-settings) + (define/override (metadata->settings metadata) + (let* ([table (metadata->table metadata)] ;; extract the table + [ssv (assoc 'deinprogramm-settings table)]) + (if ssv + (let ([settings-list (vector->list (cadr ssv))]) + (if (equal? (length settings-list) + (procedure-arity make-deinprogramm-lang-settings)) + (apply make-deinprogramm-lang-settings + (for/list ([i (in-naturals)] + [e (in-list settings-list)]) + (cond + [(= i deinprogramm-teachpacks-field-index) + (unmarshall-teachpack-settings e)] + [else e]))) + (default-settings))) + (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 (metadata->table metadata) + (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))) + + ;; cannot-compile? : path -> boolean + ;; returns #t if the file cannot be compiled, #f otherwise + (define (cannot-compile? path) + (call-with-input-file path + (lambda (port) + (let ([ok-to-compile-names + (map (lambda (x) (format "~s" x)) + '(wxtext + (lib "comment-snip.ss" "framework") + (lib "xml-snipclass.ss" "xml") + (lib "scheme-snipclass.ss" "xml") + (lib "test-case-box-snipclass.ss" "test-suite")))]) + (and (is-wxme-stream? port) + (let-values ([(snip-class-names data-class-names) + (extract-used-classes port)]) + (not (and (andmap + (lambda (used-name) (member used-name ok-to-compile-names)) + snip-class-names) + (andmap + (lambda (used-name) (member used-name ok-to-compile-names)) + data-class-names))))))))) + + (define (stepper-settings-language %) + (if (implementation? % stepper-language<%>) + (class* % (stepper-language<%>) + (init-field stepper:supported) + (define/override (stepper:supported?) stepper:supported) + (define/override (stepper:show-inexactness?) #t) + (define/override (stepper:print-boolean-long-form?) #f) + (define/override (stepper:show-consumed-and/or-clauses?) #f) + (define/override (stepper:render-to-sexp val settings language-level) + (parameterize ([pc:current-print-convert-hook (make-print-convert-hook settings)]) + (set-print-settings + language-level + settings + (lambda () + (stepper-convert-value val settings))))) + (super-new)) + (class % + (init stepper:supported) + (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)))) + + ;; make-print-convert-hook: + ;; simple-settings -> (TST (TST -> TST) (TST -> TST) -> TST) + ;; this code copied from various locations in language.rkt and rep.rkt + (define (make-print-convert-hook simple-settings) + (lambda (exp basic-convert sub-convert) + (cond + [(is-a? exp snip%) + (send exp copy)] + [else (basic-convert exp)]))) + + ;; 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))) + + + ; + ; + ; + ; + ; + ; ; + ; ;;; ; ; ; ; ;;; ; ; ;;;; ; ; ;;; ;;; ;;; + ; ; ; ;; ;; ; ; ;; ; ;; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ;;;;;; ; ; ; ; ; ; ; ;;;; ; ;;;;;; + ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ;;;; ; ; ;;; ; ;; ; ;;;;; ;;; ;;;; + ; + ; + ; + + (define mf-note + (let ([bitmap + (make-object bitmap% + (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)) + (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)) + + (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 (and (path? (car mark)) + ;; exclude paths that result from macro expansion, + ;; specifically define-record-functions + ;; see racket/drracket#157 + (not (deinprogramm-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 + ;; + + ;; WARNING: much code copied from "collects/lang/htdp-langs.rkt" + + (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 + (lambda () + (let ([on-sd (make-object style-delta%)] + [off-sd (make-object style-delta%)]) + (cond + [(preferences:get 'framework:white-on-black?) + (send on-sd set-delta-foreground "white") + (send off-sd set-delta-background "lightblue") + (send off-sd set-delta-foreground "black")] + [else + (send on-sd set-delta-foreground "black") + (send off-sd set-delta-background "lightblue") + (send off-sd set-delta-foreground "black")]) + (send rep set-test-coverage-info ht on-sd off-sd #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 'sdp-langs + "internal-error: no test-coverage table"))] + [v (hash-ref ht expr + (lambda () + (error 'sdp-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^))) + + ;; 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-deinprogramm-language : (instanceof deinprogramm-language<%>) -> void + (define (add-deinprogramm-language o) + (drscheme:language-configuration:add-language + o + #:allow-executable-creation? #t)) + + (define (phase1) (void)) + + ;; phase2 : -> void + (define (phase2) + (define (make-deinprogramm-language% printing-style writing-style) + (debugger-settings-language + (stepper-settings-language + ((drscheme:language:get-default-mixin) + (language-extension + (drscheme:language:module-based-language->language-mixin + (module-based-language-extension + printing-style writing-style + (drscheme:language:simple-module-based-language->module-based-language-mixin + simple-deinprogramm-language%)))))))) + + (add-deinprogramm-language + (instantiate (make-deinprogramm-language% 'write 'explicit) () + (module '(lib "deinprogramm/sdp/beginner.rkt")) + (manual #"sdp-beginner") + (language-position (list (string-constant teaching-languages) + "DeinProgramm" "Schreibe Dein Programm! - Anfänger")) + (language-id "sdp:beginner") + (language-numbers '(-500 -300 3 + )) + (sharing-printing #f) + (abbreviate-cons-as-list #t) + (allow-sharing? #f) + (reader-module '(lib "beginner-reader.rkt" "deinprogramm" "sdp")) + (stepper:supported #t))) + + (add-deinprogramm-language + (instantiate (make-deinprogramm-language% 'write 'explicit) () + (module '(lib "deinprogramm/sdp/vanilla.rkt")) + (manual #"sdp-vanilla") + (language-position (list (string-constant teaching-languages) + "DeinProgramm" "Schreibe Dein Programm!")) + (language-id "sdp:vanilla") + (language-numbers '(-500 -300 4)) + (sharing-printing #f) + (abbreviate-cons-as-list #t) + (allow-sharing? #f) + (reader-module '(lib "vanilla-reader.rkt" "deinprogramm" "sdp")) + (stepper:supported #t))) + + (add-deinprogramm-language + (instantiate (make-deinprogramm-language% 'write 'datum) () + (module '(lib "deinprogramm/sdp/advanced.rkt")) + (manual #"sdp-advanced") + (language-position (list (string-constant teaching-languages) + "DeinProgramm" "Schreibe Dein Programm! - fortgeschritten")) + (language-id "sdp:advanced") + (language-numbers '(-500 -300 6)) + (sharing-printing #t) + (abbreviate-cons-as-list #t) + (allow-sharing? #t) + (reader-module '(lib "advanced-reader.rkt" "deinprogramm" "sdp")) + (stepper:supported #f) + (debugger:supported #t)))))) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/private/sdp-reader.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/private/sdp-reader.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/private/sdp-reader.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/private/sdp-reader.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,45 @@ +#lang scheme/base + + (require mzlib/etc) + (provide make-read-syntax + make-read) + + (define (make-read spec) + (let ([read + (opt-lambda ([port (current-input-port)]) + (syntax->datum ((make-read-syntax spec) 'whatever port)))]) + read)) + + (define (get-all-exps source-name port) + (let loop () + (let ([exp (read-syntax source-name port)]) + (cond + [(eof-object? exp) null] + [else (cons exp (loop))])))) + + (define (lookup key table) + (let ([ans (assoc key table)]) + (unless ans + (error 'special-reader "couldn't find ~s in table ~s" + key table)) + (cadr ans))) + + (define (make-read-syntax spec) + (let ([read-syntax + (opt-lambda ([source-name #f] + [port (current-input-port)]) + (let* ([table (read port)] + [path (object-name port)] + [modname + (if (path-string? path) + (let-values ([(base name dir) (split-path path)]) + (string->symbol (path->string (path-replace-suffix name #"")))) + (lookup 'modname table))]) + (datum->syntax + #f + `(module ,modname ,spec + ,@(map (lambda (x) `(require ,x)) + (lookup 'teachpacks table)) + ,@(parameterize ([read-case-sensitive (lookup 'read-case-sensitive table)]) + (get-all-exps source-name port))))))]) + read-syntax)) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/record.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/record.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/record.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/record.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,353 @@ +#lang scheme/base + +(provide define-record-functions) + +(require scheme/promise + mzlib/struct + mzlib/pconvert-prop + mzlib/pretty + deinprogramm/signature/signature + deinprogramm/signature/signature-german + deinprogramm/signature/signature-syntax + (only-in deinprogramm/quickcheck/quickcheck arbitrary-record arbitrary-one-of)) + +(require deinprogramm/private/explicit-write) + +(require (for-syntax scheme/base) + (for-syntax deinprogramm/private/syntax-checkers) + (for-syntax stepper/private/syntax-property) + (for-syntax racket/struct-info) + (for-syntax syntax/struct)) + +(define any (signature any %any)) + +(begin-for-syntax + (define (filter-map proc l) + (if (null? l) + '() + (let ((result (proc (car l)))) + (if result + (cons result (filter-map proc (cdr l))) + (filter-map proc (cdr l)))))) + + (define (syntax-member? thing stuff) + (cond + ((null? stuff) #f) + ((free-identifier=? thing (car stuff)) #t) + (else (syntax-member? thing (cdr stuff))))) + + (define (map-with-index proc list) + (let loop ((i 0) (list list) (rev-result '())) + (if (null? list) + (reverse rev-result) + (loop (+ 1 i) + (cdr list) + (cons (proc i (car list)) rev-result)))))) + +(define-syntax define-record-functions* + (lambda (x) + (syntax-case x () + ((_ ?stx + ?type-spec + ?constructor + ?predicate + (?accessor ?field-signature) ...) + + (with-syntax + (((?type-name ?type-params ...) + (if (identifier? #'?type-spec) + #'(?type-spec) + #'?type-spec)) + (number-of-fields (length (syntax->list (syntax (?accessor ...)))))) + (with-syntax + (((accessor-proc ...) + (map-with-index + (lambda (i accessor) + (with-syntax ((i i) + (tag accessor)) + (syntax-property (syntax/loc + accessor + (lambda (s) + (when (not (raw-predicate s)) + (raise + (make-exn:fail:contract + (string->immutable-string + (format "~a: Argument kein ~a: ~e" + 'tag '?type-name s)) + (current-continuation-marks)))) + (raw-generic-access s i))) + 'inferred-name + (syntax-e accessor)))) + (syntax->list #'(?accessor ...)))) + ((our-accessor ...) (generate-temporaries #'(?accessor ...))) + (real-constructor + ;; use a different name for the value binding, but + ;; make sure the stepper prints the one from the d-r-p form + (let ((name #`?constructor)) + (stepper-syntax-property + (datum->syntax + #f + (string->uninterned-symbol + (symbol->string (syntax-e name)))) + 'stepper-orig-name + name))) + (constructor-proc + (syntax-property #'(lambda (?accessor ...) + (raw-constructor ?accessor ... #f)) + 'inferred-name + (syntax-e #'?constructor))) + (predicate-proc + (syntax-property #'(lambda (thing) + (raw-predicate thing)) + 'inferred-name + (syntax-e #'?predicate))) + ((raw-accessor-proc ...) + (map-with-index (lambda (i _) + #`(lambda (r) + (raw-generic-access r #,i))) + (syntax->list #'(?accessor ...)))) + ((raw-mutator-proc ...) + (map-with-index (lambda (i _) + #`(lambda (r val) + (raw-generic-mutate r #,i val))) + (syntax->list #'(?accessor ...)))) + (record-equal? #`(lambda (r1 r2 equal?) + (and #,@(map-with-index (lambda (i _) + #`(equal? (raw-generic-access r1 #,i) + (raw-generic-access r2 #,i))) + (syntax->list #'(?accessor ...)))))) + ((?type-param-bindings ...) + (map (lambda (type-param) + (with-syntax ((?type-param type-param) + (?type-var (string->symbol + (string-append "%" (symbol->string (syntax->datum type-param)))))) + #'(?type-param (signature ?type-var)))) + (syntax->list #'(?type-params ...))))) + + + (with-syntax + ((struct-type-defs + #'(define-values (type-descriptor + raw-constructor + raw-predicate + raw-generic-access + raw-generic-mutate) + (make-struct-type + '?type-name #f (+ 1 number-of-fields) 0 + #f + (list + (cons prop:print-convert-constructor-name + '?constructor) + (cons prop:custom-write + (make-constructor-style-printer + (lambda (obj) + (string->symbol (string-append "record:" (symbol->string '?type-name)))) + (lambda (obj) + (access-record-fields obj raw-generic-access number-of-fields)))) + (cons prop:print-converter + (lambda (r recur) + (list '?constructor + (recur (raw-accessor-proc r)) ...))) + (cons prop:equal+hash + (list record-equal? + (make-equal-hash (lambda (r i) (raw-generic-access r i)) number-of-fields) + (make-equal2-hash (lambda (r i) (raw-generic-access r i)) number-of-fields))) + (cons prop:lazy-wrap + (make-lazy-wrap-info constructor-proc + (list raw-accessor-proc ...) + (list raw-mutator-proc ...) + (lambda (r) + (raw-generic-access r number-of-fields)) + (lambda (r val) + (raw-generic-mutate r number-of-fields val))))) + (make-inspector)))) + (real-constructor-def + #'(define/signature real-constructor + (let (?type-param-bindings ...) + (signature (?field-signature ... -> ?type-spec))) + constructor-proc)) + (constructor-def #'(define-syntax ?constructor + (let () + (define-struct info () + #:super struct:struct-info + ;; support `signature' + #:property + prop:procedure + (lambda (_ stx) + (syntax-case stx () + [(self . args) (syntax/loc stx (real-constructor . args))] + [else (syntax/loc stx real-constructor)]))) + (make-info (lambda () + (list #f + #'real-constructor + #'real-predicate + (reverse (syntax->list #'(our-accessor ...))) + (map (lambda (_) #f) (syntax->list #'(our-accessor ...))) + #f)))))) + (predicate-def #'(define-values (?predicate real-predicate) + (values predicate-proc predicate-proc))) + (accessor-defs #'(define-values (?accessor ... our-accessor ...) + (values accessor-proc ... accessor-proc ...))) + (signature-def + (with-syntax (((?param ...) (generate-temporaries #'(?accessor ...)))) + (with-syntax (((component-signature ...) + (map (lambda (accessor param) + (with-syntax ((?accessor accessor) + (?param param)) + #'(at ?param (property ?accessor ?param)))) + (syntax->list #'(our-accessor ...)) + (syntax->list #'(?param ...))))) + (stepper-syntax-property + #'(define ?type-spec + (let* ((sigs (list (signature ?field-signature) ...)) + (sig + (make-lazy-wrap-signature '?type-name #t + type-descriptor raw-predicate + sigs + #'?type-name))) + (set-signature-arbitrary-promise! + sig + (delay + (let ((arbs (map signature-arbitrary sigs))) + (when (andmap values arbs) + (apply arbitrary-record + real-constructor + (list raw-accessor-proc ...) + arbs))))) + sig)) + 'stepper-skip-completely + #t))))) + ;; again, with properties + (with-syntax ((struct-type-defs + (stepper-syntax-property + (syntax/loc x struct-type-defs) 'stepper-black-box-expr #'?stx)) + (real-constructor-def + (stepper-syntax-property #'real-constructor-def 'stepper-skip-completely #t)) + (predicate-def + (stepper-syntax-property #'predicate-def 'stepper-skip-completely #t)) + (accessor-defs + (stepper-syntax-property #'accessor-defs 'stepper-skip-completely #t))) + #'(begin + struct-type-defs + signature-def + ;; the signature might be used in the definitions, hence this ordering + predicate-def real-constructor-def constructor-def accessor-defs))))))))) + +(define (access-record-fields rec acc count) + (let recur ((i 0)) + (if (= i count) + '() + (cons (acc rec i) + (recur (+ i 1)))))) + +(define (make-equal-hash generic-access field-count) + (lambda (r recur) + (let loop ((i 0) + (factor 1) + (hash 0)) + (if (= i field-count) + hash + (loop (+ 1 i) + (* factor 33) + (+ hash (* factor (recur (generic-access r i))))))))) + +(define (make-equal2-hash generic-access field-count) + (lambda (r recur) + (let loop ((i 0) + (factor 1) + (hash 0)) + (if (= i field-count) + hash + (loop (+ 1 i) + (* factor 33) + (+ hash (* factor + (recur (generic-access r (- field-count i 1)))))))))) + +;; FIXME: duplicate from primitives.rkt +(define-for-syntax (binding-in-this-module? b) + (and (list? b) + (module-path-index? (car b)) + (let-values (((path base) (module-path-index-split (car b)))) + (and (not path) (not base))))) + +(define-for-syntax (check-id-unbound! id) + (cond + ((identifier-binding id) + => (lambda (binding) + (if (binding-in-this-module? binding) + (raise-syntax-error + #f + "Es gibt schon eine Definition für den Namen" + id) + (raise-syntax-error + #f + "Dieser Name gehört einer eingebauten Funktion" + id)))))) + +;; (define-record-functions :pare kons pare? (kar integer) (kdr list-of-integers)) + +(define-syntax define-record-functions + (lambda (x) + (syntax-case x () + ((_ ?type-spec) + (raise-syntax-error + #f + "Zu wenige Operanden für define-record-functions" x)) + ((_ ?type-spec ?constructor) ; nullary case + #'(define-record-functions ?type-spec ?constructor dummy-predicate)) + ((_ ?type-spec + ?constructor + (?accessor ?signature) ?field-spec ...) + #'(define-record-functions ?type-spec ?constructor dummy-predicate (?accessor ?signature) ?field-spec ...)) + + ((_ ?type-spec + ?constructor + ?predicate + ?field-spec ...) + + (with-syntax (((?type-name ?type-params ...) + (if (identifier? #'?type-spec) + #'(?type-spec) + #'?type-spec))) + + (check-for-id! + (syntax ?type-name) + "Typ ist kein Name") + + (for-each (lambda (type-param) + (check-for-id! + type-param + "Parameter zu Typ-Konstruktor ist kein Name")) + (syntax->list #'(?type-params ...))) + + (check-for-id! + (syntax ?constructor) + "Konstruktor ist kein Name") + + (check-for-id! + (syntax ?predicate) + "Prädikat ist kein Name") + + (check-id-unbound! #'?type-name) + (check-id-unbound! #'?constructor) + (check-id-unbound! #'?predicate) + + (for-each + (lambda (field-spec) + (syntax-case field-spec () + ((?accessor ?selector) + (begin + (check-for-id! #'?accessor "Selektor ist kein Name") + (check-id-unbound! #'?accessor))) + (?stuff + (raise-syntax-error #f "Feld hat nicht die Form (Selektor Signatur)" #'?stuff)))) + (syntax->list #'(?field-spec ...))) + + + (with-syntax ((?stx x)) + #'(define-record-functions* ?stx ?type-spec + ?constructor + ?predicate + ?field-spec ...))))))) + + diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/tests/match.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/tests/match.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/tests/match.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/tests/match.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,118 @@ +#lang racket/base + +(provide all-match-tests) + +(require rackunit + deinprogramm/sdp/record + deinprogramm/signature/signature-syntax + (only-in deinprogramm/sdp/private/primitives match empty cons)) + +(define any (signature any %any)) + +(define-record-functions pare + kons pare? + (kar any) + (kdr any)) + +(define-record-functions bare + gons bare? + (gar any) + (gdr any)) + +(define-record-functions nullary + make-nullary nullary?) + +(define all-match-tests + (test-suite + "Tests for DeinProgramm match form." + + (test-case + "literals" + (define foo + (lambda (x) + (match x + (#t 'true) + (#f 'false) + ('() 'nil) + ('(foo bar) 'foobar) + ("foo" 'foo) + ("bar" 'bar) + (5 'five) + (2 'two)))) + + (check-equal? (foo #t) 'true) + (check-equal? (foo #f) 'false) + (check-equal? (foo '()) 'nil) + (check-equal? (foo '(foo bar)) 'foobar) + (check-equal? (foo "foo") 'foo) + (check-equal? (foo "bar") 'bar) + (check-equal? (foo 5) 'five) + (check-equal? (foo 2) 'two)) + + + (test-case + "variables" + (define foo + (lambda (x) + (match x + (#t 'true) + (foo (list 'foo foo))))) + (check-equal? (foo #t) 'true) + (check-equal? (foo "foo") '(foo "foo"))) + + (test-case + "lists" + (define foo + (lambda (x) + (match x + (empty 'empty) + ((cons 'foo empty) 'fooempty) + ((list 'foo 'bar) 'listfoobar) + ((list 'bar 'foo) 'listbarfoo) + ((list a b c) (list 'list a b c)) + ((cons 5 b) (list 'cons5 b)) + ((cons a (cons b c)) (list 'cons a b c)) + ((cons a b) (list 'cons a b)) + (x (list 'x x))))) + + (check-equal? (foo empty) 'empty) + (check-equal? (foo "empty") '(x "empty")) + (check-equal? (foo (list 1 2 3)) '(list 1 2 3)) + (check-equal? (foo (cons 'foo empty)) 'fooempty) + (check-equal? (foo (cons 1 empty)) '(cons 1 ())) + (check-equal? (foo (cons 5 empty)) '(cons5 ())) + (check-equal? (foo (list 1 2)) '(cons 1 2 ())) + (check-equal? (match empty ((list) 'bingo)) 'bingo) + (check-equal? (match (list 1) ((list) 'bingo) (foo foo)) (list 1)) + (check-equal? (foo (list 'foo 'bar)) 'listfoobar) + (check-equal? (foo (list 'bar 'foo)) 'listbarfoo)) + + (test-case + "anything" + (check-equal? (match 5 (_ 7)) 7) + (check-equal? (match '(1 2) (_ 7)) 7) + (check-equal? (match #f (_ 7)) 7) + (check-equal? (let ((_ 5)) (match #f (_ _))) 5) + (check-equal? (match #f + ((kons _ _) 7) + (_ 5)) + 5) + (check-equal? (match (kons 1 2) + ((kons _ _) 7) + (_ 5)) + 7)) + + (test-case + "records" + (define foo + (lambda (x) + (match x + ((cons foo empty) 'pairfoo) + ((make-nullary) 'nullary) + ((kons a b) (list 'kons a b)) + ((gons a b) (list 'gons a b))))) + + (check-equal? (foo (cons foo empty)) 'pairfoo) + (check-equal? (foo (make-nullary)) 'nullary) + (check-equal? (foo (kons 1 2)) '(kons 1 2)) + (check-equal? (foo (gons 1 2)) '(gons 1 2))))) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/tests/record.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/tests/record.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/tests/record.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/tests/record.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,90 @@ +#lang racket/base + +(provide all-record-tests) + +(require rackunit + deinprogramm/sdp/record + deinprogramm/signature/signature-syntax + (only-in deinprogramm/signature/signature signature?) + racket/match) + +(define any (signature any %any)) +(define rational (signature (predicate rational?))) +(define string (signature (predicate string?))) + +(define-record-functions pare + kons pare? + (kar any) + (kdr any)) + +(define-record-functions paire + koins + (kair any) + (kdir any)) + +(define-record-functions chocolate-cookie + make-chocolate-cookie chocolate-cookie? + (chocolate-cookie-chocolate rational) + (chocolate-cookie-cookie rational)) + +(define-record-functions (ppare a) + pkons pkons? + (pkar a) + (pkdr any)) + +(define-record-functions nullary + make-nullary nullary?) + +(define all-record-tests + (test-suite + "Tests for DeinProgramm records." + + (test-case + "basics" + (define p1 (kons 1 2)) + (define p2 (kons 3 4)) + + (check-true (pare? p1)) + (check-true (pare? p2)) + + (check-false (pare? 5)) + (check-false (pare? (make-chocolate-cookie 1 2))) + + (check-equal? (kar p1) 1) + (check-equal? (kdr p1) 2) + (check-equal? (kar p2) 3) + (check-equal? (kdr p2) 4)) + + (test-case + "no predicate" + + (define p1 (koins 1 2)) + (define p2 (koins 3 4)) + + (check-equal? (kair p1) 1) + (check-equal? (kdir p1) 2) + (check-equal? (kair p2) 3) + (check-equal? (kdir p2) 4) + + (check-true (signature? paire))) + + (test-case + "matching" + (define p (kons 1 2)) + (define c (make-chocolate-cookie 3 4)) + + (define t + (lambda (r) + (match r + ((kons a b) (list 'kons a b)) + ((make-chocolate-cookie ch ck) (list 'make-chocolate-cookie ch ck))))) + + (check-equal? (t p) '(kons 1 2)) + (check-equal? (t c) '(make-chocolate-cookie 3 4))) + + (test-case + "parametric" + (define p (pkons 1 2)) + + (check-equal? (pkar p) 1) + (check-equal? (pkdr p) 2)))) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/tests/run-match-tests.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/tests/run-match-tests.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/tests/run-match-tests.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/tests/run-match-tests.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,6 @@ +#lang racket/base + +(require rackunit/text-ui) +(require deinprogramm/sdp/tests/match) + +(run-tests all-match-tests) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/tests/run-record-tests.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/tests/run-record-tests.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/tests/run-record-tests.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/tests/run-record-tests.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,6 @@ +#lang racket/base + +(require rackunit/text-ui) +(require deinprogramm/sdp/tests/record) + +(run-tests all-record-tests) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/tests/run-signature-tests.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/tests/run-signature-tests.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/tests/run-signature-tests.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/tests/run-signature-tests.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,6 @@ +#lang scheme/base + +(require rackunit/text-ui) +(require deinprogramm/sdp/tests/signature) + +(run-tests all-signature-tests) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/tests/signature.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/tests/signature.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/tests/signature.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/tests/signature.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,657 @@ +#lang scheme/base + +(provide all-signature-tests) + +(require rackunit + deinprogramm/sdp/record + deinprogramm/signature/signature + deinprogramm/signature/signature-german + deinprogramm/signature/signature-syntax) + +(require scheme/promise) + +(define integer (make-predicate-signature 'integer integer? 'integer-marker)) +(define boolean (make-predicate-signature 'boolean boolean? 'boolean-marker)) +(define %a (make-type-variable-signature 'a 'a-marker)) +(define %b (make-type-variable-signature 'b 'b-marker)) + +(define-syntax say-no + (syntax-rules () + ((say-no ?body ...) + (let/ec exit + (call-with-signature-violation-proc + (lambda (obj signature message blame) + (exit 'no)) + (lambda () + ?body ...)))))) + +(define-syntax failed-signature + (syntax-rules () + ((say-no ?body ...) + (let/ec exit + (call-with-signature-violation-proc + (lambda (obj signature message blame) + (exit signature)) + (lambda () + ?body ...)))))) + +(define signature-tests + (test-suite + "Tests for signature combinators" + + (test-case + "flat" + (check-equal? (say-no (apply-signature integer 5)) 5) + (check-equal? (say-no (apply-signature integer "foo")) 'no)) + + (test-case + "list" + (define integer-list (make-list-signature 'integer-list integer #f)) + (check-equal? (say-no (apply-signature integer-list '(1 2 3))) + '(1 2 3)) + (check-equal? (say-no (apply-signature integer-list '#f)) + 'no) + (check-eq? (failed-signature (apply-signature integer-list '(1 #f 3))) + integer)) + + (test-case + "nonempty list" + (define integer-list (make-nonempty-list-signature 'integer-list integer #f)) + (check-equal? (say-no (apply-signature integer-list '(1 2 3))) + '(1 2 3)) + (check-equal? (say-no (apply-signature integer-list '#f)) + 'no) + (check-equal? (say-no (apply-signature integer-list '())) + 'no) + (check-eq? (failed-signature (apply-signature integer-list '(1 #f 3))) + integer)) + + (test-case + "list-cached" + (define integer-list (make-list-signature 'integer-list integer #f)) + (define boolean-list (make-list-signature 'integer-list boolean #f)) + (define l '(1 2 3)) + (define foo "foo") + (define no '(1 #f 3)) + (define no2 '(1 #f 3)) + (define integer-list->bool (make-procedure-signature 'integer-list->bool (list integer-list) boolean 'int->bool-marker)) + + (check-equal? (say-no (apply-signature integer-list l)) + '(1 2 3)) + (check-equal? (say-no (apply-signature integer-list l)) + '(1 2 3)) + (check-equal? (say-no (apply-signature boolean-list l)) + 'no) + (check-equal? (say-no (apply-signature integer-list foo)) + 'no) + (check-equal? (say-no (apply-signature integer-list foo)) + 'no) + (check-eq? (failed-signature (apply-signature integer-list no)) + integer) + (check-eq? (failed-signature (apply-signature integer-list no)) + integer) + + (let ((proc (say-no (apply-signature integer-list->bool (lambda (l) (even? (car l))))))) + (check-equal? (say-no (proc no)) 'no) + (check-equal? (say-no (proc no)) 'no) + (check-equal? (say-no (proc no2)) 'no) + (check-equal? (say-no (proc no2)) 'no)) + ) + + (test-case + "vector" + (define integer-vector (make-vector-signature 'integer-vector integer #f)) + (define a-vector (make-vector-signature 'a-vector %a #f)) + (check-equal? (say-no (apply-signature integer-vector '#(1 2 3))) + '#(1 2 3)) + (check-equal? (say-no (apply-signature a-vector '#(1 2 3))) + '#(1 2 3)) + (check-equal? (say-no (apply-signature integer-vector '#f)) + 'no) + (check-eq? (failed-signature (apply-signature integer-vector '#(1 #f 3))) + integer)) + + (test-case + "vector/cached" + (let ((count 0)) + (define counting-integer + (make-predicate-signature 'counting-integer + (lambda (obj) + (set! count (+ 1 count)) + (integer? obj)) + 'integer-marker)) + + (define integer-vector (make-vector-signature 'integer-list counting-integer #f)) + + (define v1 '#(1 2 3)) + + (check-eq? (say-no (apply-signature integer-vector v1)) + v1) + (check-equal? count 3) + (check-eq? (say-no (apply-signature integer-vector v1)) + v1) + (check-equal? count 3))) + + + (test-case + "mixed" + (define int-or-bool (make-mixed-signature 'int-or-bool + (list integer + boolean) + 'int-or-bool-marker)) + (check-equal? (say-no (apply-signature int-or-bool #f)) + #f) + (check-equal? (say-no (apply-signature int-or-bool 17)) + 17) + (check-equal? (say-no (apply-signature int-or-bool "foo")) + 'no)) + + (test-case + "combined" + (define octet (make-combined-signature + 'octet + (list + integer + (make-predicate-signature '<256 + (delay (lambda (x) + (< x 256))) + '<256-marker) + (make-predicate-signature 'non-negative + (delay (lambda (x) + (>= x 0))) + 'non-negative-marker)) + 'octet-marker)) + (check-equal? (say-no (apply-signature octet #f)) + 'no) + (check-equal? (say-no (apply-signature octet 17)) + 17) + (check-equal? (say-no (apply-signature octet 0)) + 0) + (check-equal? (say-no (apply-signature octet -1)) + 'no) + (check-equal? (say-no (apply-signature octet 255)) + 255) + (check-equal? (say-no (apply-signature octet 256)) + 'no) + (check-equal? (say-no (apply-signature octet "foo")) + 'no)) + + (test-case + "case" + (define foo-or-bar (make-case-signature 'foo-or-bar '("foo" "bar") equal? 'foo-or-bar-marker)) + (check-equal? (say-no (apply-signature foo-or-bar #f)) + 'no) + (check-equal? (say-no (apply-signature foo-or-bar "foo")) + "foo") + (check-equal? (say-no (apply-signature foo-or-bar "bar")) + "bar")) + + (test-case + "procedure" + (define int->bool (make-procedure-signature 'int->bool (list integer) boolean 'int->bool-marker)) + (check-equal? (say-no (apply-signature int->bool #f)) + 'no) + (check-equal? (say-no (apply-signature int->bool (lambda () "foo"))) + 'no) + (check-equal? (say-no (apply-signature int->bool (lambda (x y) "foo"))) + 'no) + (let ((proc (say-no (apply-signature int->bool (lambda (x) (odd? x)))))) + (check-pred procedure? proc) + (check-equal? (proc 15) #t) + (check-equal? (proc 16) #f) + (check-equal? (say-no (proc "foo")) 'no)) + (let ((proc (say-no (apply-signature int->bool (lambda (x) (+ x 1)))))) + (check-equal? (say-no (proc 12)) 'no))) + + (test-case + "type variable - simple" + (check-equal? (say-no (apply-signature %a #f)) #f) + (check-equal? (say-no (apply-signature %a 15)) 15)) + + (test-case + "type variable - list" + (define a-list (make-list-signature 'a-list %a #f)) + (check-equal? (say-no (apply-signature a-list '(1 2 3))) + '(1 2 3)) + (check-equal? (say-no (apply-signature a-list '#f)) + 'no) + (check-equal? (say-no (apply-signature a-list '(#f "foo" 5))) + '(#f "foo" 5))) + + (test-case + "apply-signature/blame" + (define int->bool (make-procedure-signature 'int->bool (list integer) boolean 'int->bool-marker)) + (let ((proc (say-no (apply-signature/blame int->bool (lambda (x) (odd? x)))))) + (check-pred procedure? proc) + (check-equal? (proc 15) #t) + (check-equal? (proc 16) #f) + (check-equal? (say-no (proc "foo")) 'no)) + (let ((proc (say-no (apply-signature/blame int->bool (lambda (x) x))))) + (call-with-signature-violation-proc + (lambda (obj signature message blame) + (check-true (syntax? blame))) + (lambda () + (proc 5))))) + )) + +(define signature-syntax-tests + (test-suite + "Tests for signature syntax" + + (test-case + "predicate" + (define integer (signature (predicate integer?))) + (check-equal? (say-no (apply-signature integer 5)) 5) + (check-equal? (say-no (apply-signature integer "foo")) 'no)) + + (test-case + "list" + (check-equal? (say-no (apply-signature (signature x (list-of %a)) 5)) 'no) + (check-equal? (say-no (apply-signature (signature x (list-of %a)) '(1 2 3))) '(1 2 3)) + (check-equal? (say-no (apply-signature (signature x (list-of (predicate integer?))) '(1 2 3))) '(1 2 3)) + (check-equal? (say-no (apply-signature (signature x (list-of (predicate integer?))) '(1 #f 3))) 'no)) + + (test-case + "mixed" + (define int-or-bool (signature (mixed integer boolean))) + (check-equal? (say-no (apply-signature int-or-bool #f)) + #f) + (check-equal? (say-no (apply-signature int-or-bool 17)) + 17) + (check-equal? (say-no (apply-signature int-or-bool "foo")) + 'no)) + + (test-case + "combined" + (define octet (signature (combined integer + (predicate (lambda (x) + (< x 256))) + (predicate (lambda (x) + (>= x 0)))))) + (check-equal? (say-no (apply-signature octet #f)) + 'no) + (check-equal? (say-no (apply-signature octet 17)) + 17) + (check-equal? (say-no (apply-signature octet 0)) + 0) + (check-equal? (say-no (apply-signature octet -1)) + 'no) + (check-equal? (say-no (apply-signature octet 255)) + 255) + (check-equal? (say-no (apply-signature octet 256)) + 'no) + (check-equal? (say-no (apply-signature octet "foo")) + 'no)) + + (test-case + "procedure" + (define int->bool (signature int->bool ((predicate integer?) -> (predicate boolean?)))) + (check-equal? (say-no (apply-signature int->bool #f)) + 'no) + (check-equal? (say-no (apply-signature int->bool (lambda () "foo"))) + 'no) + (check-equal? (say-no (apply-signature int->bool (lambda (x y) "foo"))) + 'no) + (let ((proc (say-no (apply-signature int->bool (lambda (x) (odd? x)))))) + (check-pred procedure? proc) + (check-equal? (proc 15) #t) + (check-equal? (proc 16) #f) + (check-equal? (say-no (proc "foo")) 'no)) + (let ((proc (say-no (apply-signature int->bool (lambda (x) (+ x 1)))))) + (check-equal? (say-no (proc 12)) 'no))) + + + (test-case + "record-wrap" + (define-record-functions (pare-of a b) kons pare? (kar a) (kdr b)) + (define ctr (pare-of integer boolean)) + (let ((obj (apply-signature ctr (kons 1 #t)))) + (check-equal? (kar obj) 1) + (check-equal? (kdr obj) #t)) + (check-equal? (say-no (apply-signature ctr (kons 1 2))) 'no) + ) + + (test-case + "record-wrap/lazy" + (define-struct pare (kar kdr extra) + #:mutable + #:property prop:lazy-wrap + (make-lazy-wrap-info + (lambda (kar kdr) (kons kar kdr)) + (list (lambda (x) (pare-kar x)) (lambda (x) (pare-kdr x))) + (list (lambda (x v) (set-pare-kar! x v)) + (lambda (x v) (set-pare-kdr! x v))) + (lambda (x) (pare-extra x)) (lambda (x v) (set-pare-extra! x v)))) + (define (kons kar kdr) + (make-pare kar kdr #f)) + (define (kar p) + (check-lazy-wraps! struct:pare p) + (pare-kar p)) + (define (kdr p) + (check-lazy-wraps! struct:pare p) + (pare-kdr p)) + (define (pare-of kar-sig kdr-sig) + (make-lazy-wrap-signature 'pare #f + struct:pare + pare? + (list kar-sig kdr-sig) + #f)) + (define ctr (pare-of integer boolean)) + (let ((obj (apply-signature ctr (kons 1 #t)))) + (check-equal? (kar obj) 1) + (check-equal? (kdr obj) #t)) + (let ((obj (apply-signature ctr (kons 1 2)))) + (check-equal? (say-no (kar obj)) 'no)) + ) + + (test-case + "record-wrap-2" + (let ((count 0)) + (define counting-integer + (make-predicate-signature 'counting-integer + (lambda (obj) + (set! count (+ 1 count)) + (integer? obj)) + 'integer-marker)) + (define-record-functions (pare-of a b) kons pare? (kar a) (kdr b)) + (define ctr (signature (pare-of counting-integer boolean))) + (let ((obj (apply-signature ctr (apply-signature ctr (kons 1 #t))))) + (check-equal? count 1) + (check-equal? (kar obj) 1) + (check-equal? count 1) + (check-equal? (kdr obj) #t) + (check-equal? count 1)))) + + (test-case + "record-wrap-2/lazy" + (let ((count 0)) + (define counting-integer + (make-predicate-signature 'counting-integer + (lambda (obj) + (set! count (+ 1 count)) + (integer? obj)) + 'integer-marker)) + + (define-struct pare (kar kdr extra) + #:mutable + #:property prop:lazy-wrap + (make-lazy-wrap-info + (lambda (kar kdr) (kons kar kdr)) + (list (lambda (x) (pare-kar x)) (lambda (x) (pare-kdr x))) + (list (lambda (x v) (set-pare-kar! x v)) + (lambda (x v) (set-pare-kdr! x v))) + (lambda (x) (pare-extra x)) (lambda (x v) (set-pare-extra! x v)))) + (define (kons kar kdr) + (make-pare kar kdr #f)) + (define (kar p) + (check-lazy-wraps! struct:pare p) + (pare-kar p)) + (define (kdr p) + (check-lazy-wraps! struct:pare p) + (pare-kdr p)) + (define (pare-of kar-sig kdr-sig) + (make-lazy-wrap-signature 'pare #f + struct:pare + pare? + (list kar-sig kdr-sig) + #f)) + + (define ctr (signature (pare-of counting-integer boolean))) + (let ((obj (apply-signature ctr (apply-signature ctr (kons 1 #t))))) + (check-equal? count 0) + (check-equal? (kar obj) 1) + (check-equal? count 1) + (check-equal? (kdr obj) #t) + (check-equal? count 1)))) + + (test-case + "record-wrap-3" + (let ((count 0)) + (define counting-integer + (make-predicate-signature 'counting-integer + (lambda (obj) + (set! count (+ 1 count)) + (integer? obj)) + 'integer-marker)) + + (define-record-functions (pare-of a b) kons pare? (kar a) (kdr b)) + (define ctr (signature (pare-of counting-integer boolean))) + (let ((obj (apply-signature ctr (apply-signature ctr (kons 1 #t))))) + (check-equal? count 1) + (check-equal? (kar obj) 1) + (check-equal? count 1) + (check-equal? (kdr obj) #t) + (check-equal? count 1) + ;; after checking, the system should remember that it did so + (let ((obj-2 (apply-signature ctr obj))) + (check-equal? count 1) + (check-equal? (kar obj) 1) + (check-equal? count 1) + (check-equal? (kdr obj) #t) + (check-equal? count 1))))) + + (test-case + "record-wrap-3/lazy" + (let ((count 0)) + (define counting-integer + (make-predicate-signature 'counting-integer + (lambda (obj) + (set! count (+ 1 count)) + (integer? obj)) + 'integer-marker)) + (define-struct pare (kar kdr extra) + #:mutable + #:property prop:lazy-wrap + (make-lazy-wrap-info + (lambda (kar kdr) (kons kar kdr)) + (list (lambda (x) (pare-kar x)) (lambda (x) (pare-kdr x))) + (list (lambda (x v) (set-pare-kar! x v)) + (lambda (x v) (set-pare-kdr! x v))) + (lambda (x) (pare-extra x)) (lambda (x v) (set-pare-extra! x v)))) + (define (kons kar kdr) + (make-pare kar kdr #f)) + (define (kar p) + (check-lazy-wraps! struct:pare p) + (pare-kar p)) + (define (kdr p) + (check-lazy-wraps! struct:pare p) + (pare-kdr p)) + (define (pare-of kar-sig kdr-sig) + (make-lazy-wrap-signature 'pare #f + struct:pare + pare? + (list kar-sig kdr-sig) + #f)) + + (define ctr (signature (pare-of counting-integer boolean))) + (let ((obj (apply-signature ctr (apply-signature ctr (kons 1 #t))))) + (check-equal? count 0) + (check-equal? (kar obj) 1) + (check-equal? count 1) + (check-equal? (kdr obj) #t) + (check-equal? count 1) + ;; after checking, the system should remember that it did so + (let ((obj-2 (apply-signature ctr obj))) + (check-equal? count 1) + (check-equal? (kar obj) 1) + (check-equal? count 1) + (check-equal? (kdr obj) #t) + (check-equal? count 1))))) + + (test-case + "double-wrap" + (let ((count 0)) + (define counting-integer + (make-predicate-signature 'counting-integer + (lambda (obj) + (set! count (+ 1 count)) + (integer? obj)) + 'integer-marker)) + (define-record-functions (pare-of a b) raw-kons pare? (kar a) (kdr b)) + + (define empty-list (signature (predicate null?))) + + (define my-list-of + (lambda (x) + (signature (mixed empty-list + (pare-of x (my-list-of x)))))) + + (define/signature kons (signature (%a (my-list-of %a) -> (pare-of %a (my-list-of %a)))) + raw-kons) + + (define/signature build-list (signature (integer -> (my-list-of counting-integer))) + (lambda (n) + (if (= n 0) + '() + (kons n (build-list (- n 1)))))) + + (define/signature list-length (signature ((my-list-of counting-integer) -> integer)) + (lambda (lis) + (cond + ((null? lis) 0) + ((pare? lis) + (+ 1 (list-length (kdr lis))))))) + + ;; one wrap each for (my-list-of %a), one for (my-list-of counting-integer) + (let ((l1 (build-list 10))) + (check-equal? count 10) + (let ((len1 (list-length l1))) + (check-equal? count 10))))) + + (test-case + "double-wrap/lazy" + (let ((count 0)) + (define counting-integer + (make-predicate-signature 'counting-integer + (lambda (obj) + (set! count (+ 1 count)) + (integer? obj)) + 'integer-marker)) + + (define-struct pare (kar kdr extra) + #:mutable + #:property prop:lazy-wrap + (make-lazy-wrap-info + (lambda (kar kdr) (raw-kons kar kdr)) + (list (lambda (x) (pare-kar x)) (lambda (x) (pare-kdr x))) + (list (lambda (x v) (set-pare-kar! x v)) + (lambda (x v) (set-pare-kdr! x v))) + (lambda (x) (pare-extra x)) (lambda (x v) (set-pare-extra! x v)))) + (define (raw-kons kar kdr) + (make-pare kar kdr #f)) + (define (kar p) + (check-lazy-wraps! struct:pare p) + (pare-kar p)) + (define (kdr p) + (check-lazy-wraps! struct:pare p) + (pare-kdr p)) + (define (pare-of kar-sig kdr-sig) + (make-lazy-wrap-signature 'pare #f + struct:pare + pare? + (list kar-sig kdr-sig) + #f)) + + + (define empty-list (signature (predicate null?))) + + (define my-list-of + (lambda (x) + (signature (mixed empty-list + (pare-of x (my-list-of x)))))) + + (define/signature kons (signature (%a (my-list-of %a) -> (pare-of %a (my-list-of %a)))) + raw-kons) + + (define/signature build-list (signature (integer -> (my-list-of counting-integer))) + (lambda (n) + (if (= n 0) + '() + (kons n (build-list (- n 1)))))) + + (define/signature list-length (signature ((my-list-of counting-integer) -> integer)) + (lambda (lis) + (cond + ((null? lis) 0) + ((pare? lis) + (+ 1 (list-length (kdr lis))))))) + + ;; one wrap each for (my-list-of %a), one for (my-list-of counting-integer) + (let ((l1 (build-list 10))) + (check-equal? count 0) + (let ((len1 (list-length l1))) + (check-equal? count 10))))) + + (test-case + "mixed wrap" + + (define-struct pare (kar kdr extra) + #:mutable + #:property prop:lazy-wrap + (make-lazy-wrap-info + (lambda (kar kdr) (raw-kons kar kdr)) + (list (lambda (x) (pare-kar x)) (lambda (x) (pare-kdr x))) + (list (lambda (x v) (set-pare-kar! x v)) + (lambda (x v) (set-pare-kdr! x v))) + (lambda (x) (pare-extra x)) (lambda (x v) (set-pare-extra! x v)))) + (define (raw-kons kar kdr) + (make-pare kar kdr #f)) + (define (kar p) + (check-lazy-wraps! struct:pare p) + (pare-kar p)) + (define (kdr p) + (check-lazy-wraps! struct:pare p) + (pare-kdr p)) + (define (pare-of kar-sig kdr-sig) + (make-lazy-wrap-signature 'pare #f + struct:pare + pare? + (list kar-sig kdr-sig) + #f)) + + + (define sig1 (signature (pare-of integer boolean))) + (define sig2 (signature (pare-of boolean integer))) + (define sig (signature (mixed sig1 sig2))) + (define/signature x sig (raw-kons #t 15)) + (define/signature y sig (raw-kons #t #t)) + (check-equal? (kar x) #t) + (check-equal? (say-no (kar y)) 'no)) + + (test-case + "wrap equality" + (define-record-functions (pare-of a b) raw-kons pare? (kar a) (kdr b)) + + (define empty-list (signature (predicate null?))) + + (define my-list-of + (lambda (x) + (signature (mixed empty-list + (pare-of x (my-list-of x)))))) + + (define/signature kons (signature (%a (my-list-of %a) -> (pare-of %a (my-list-of %a)))) + raw-kons) + + (check-equal? (raw-kons 1 '()) (raw-kons 1 '())) + (check-equal? (kons 1 '()) (kons 1 '())) + (check-equal? (kons 1 '()) (raw-kons 1 '())) + (check-equal? (raw-kons 1 '()) (kons 1 '()))) + + (test-case + "pair-wrap" + (define sig (make-pair-signature #f integer boolean)) + (let ((obj (apply-signature sig (cons 1 #t)))) + (check-equal? (checked-car obj) 1) + (check-equal? (checked-cdr obj) #t)) + (let ((obj (apply-signature sig (cons 1 2)))) + (check-equal? (say-no (checked-car obj)) 'no)) + ) + +)) + + +(define all-signature-tests + (test-suite + "all-signature-tests" + signature-tests + signature-syntax-tests)) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/tests/test-docs-complete.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/tests/test-docs-complete.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/tests/test-docs-complete.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/tests/test-docs-complete.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,6 @@ +#lang racket/base +(require rackunit/docs-complete) + +(check-docs (quote deinprogramm/sdp/beginner) #:skip #rx"(^#%)|(^\\.\\.)|(^contract$)|(^define-contract$)") +(check-docs (quote deinprogramm/sdp/vanilla) #:skip #rx"(^#%)|(^\\.\\.)|(^contract$)|(^define-contract$)") +(check-docs (quote deinprogramm/sdp/advanced) #:skip #rx"(^#%)|(^\\.\\.)|(^contract$)|(^define-contract$)") diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/vanilla/lang/reader.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/vanilla/lang/reader.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/vanilla/lang/reader.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/vanilla/lang/reader.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,2 @@ +#lang s-exp syntax/module-reader +deinprogramm/sdp/vanilla diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/vanilla-reader.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/vanilla-reader.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/vanilla-reader.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/vanilla-reader.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,6 @@ +(module sdp-vanilla-reader mzscheme + (require deinprogramm/sdp/private/sdp-reader) + (provide (rename -read-syntax read-syntax) + (rename -read read)) + (define -read-syntax (make-read-syntax '(lib "vanilla.rkt" "deinprogramm" "sdp"))) + (define -read (make-read '(lib "vanilla.rkt" "deinprogramm" "sdp")))) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/vanilla.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/vanilla.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/sdp/vanilla.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/sdp/vanilla.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,21 @@ +#lang deinprogramm/sdp + +(require syntax/docprovide) +(provide #%app #%top (rename-out (sdp-module-begin #%module-begin)) #%datum #%top-interaction + require lib planet provide + define let let* letrec lambda λ cond if else and or + define-record-functions + match + .. ... .... ..... ...... + check-expect check-within check-error check-member-of check-range check-satisfied + check-property for-all ==> expect expect-within expect-member-of expect-range + signature contract : define-contract -> mixed one-of predicate combined list-of nonempty-list-of + number real rational integer natural boolean true false string empty-list any property) +(provide-and-document + procedures + (all-from-except vanilla: deinprogramm/sdp/private/primitives procedures + quote eq? equal? + set! + symbol? symbol=? string->symbol symbol->string + apply)) + diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/signature/module-begin.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/signature/module-begin.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/signature/module-begin.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/signature/module-begin.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -2,7 +2,7 @@ (provide module-begin) -(require deinprogramm/define-record-procedures +(require deinprogramm/DMdA/define-record-procedures deinprogramm/signature/signature deinprogramm/signature/signature-syntax) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/syntax-checkers.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/syntax-checkers.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/syntax-checkers.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/syntax-checkers.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,20 +0,0 @@ -#lang scheme/base - -(provide check-for-id! - check-for-id-list!) - -(define (check-for-id! arg error-msg) - (when (not (identifier? arg)) - (raise-syntax-error #f error-msg arg))) - -(define (check-for-id-list! args error-msg) - (for-each (lambda (arg) - (check-for-id! arg error-msg)) - args) - (cond ((check-duplicate-identifier args) - => (lambda (dup) - (raise-syntax-error - #f - "Bezeichner doppelt gebunden" - args dup))) - (else #t))) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/tests/image.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/tests/image.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/tests/image.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/tests/image.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,1038 +0,0 @@ -#lang scheme/base - -(provide all-image-tests) - -(require rackunit - deinprogramm/image - (only-in lang/private/imageeq image=?) - (except-in mred make-color make-pen) - mzlib/class - mrlib/cache-image-snip - lang/posn - htdp/error) - - -(define-values (image-snip1 image-snip2) - (let () - (define size 2) - - (define (do-draw c-bm m-bm) - (let ([bdc (make-object bitmap-dc% c-bm)]) - (send bdc clear) - (send bdc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) - (send bdc set-brush (send the-brush-list find-or-create-brush "red" 'solid)) - (send bdc draw-rectangle 0 0 size size) - (send bdc set-bitmap m-bm) - (send bdc clear) - (send bdc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) - (send bdc set-brush (send the-brush-list find-or-create-brush "black" 'solid)) - (send bdc draw-rectangle 0 0 (/ size 2) size) - (send bdc set-bitmap #f))) - - (define image-snip1 - (let* ([c-bm (make-object bitmap% size size)] - [m-bm (make-object bitmap% size size #t)]) - (do-draw c-bm m-bm) - (make-object image-snip% c-bm m-bm))) - - (define image-snip2 - (let* ([c-bm (make-object bitmap% size size)] - [m-bm (make-object bitmap% size size)]) - (do-draw c-bm m-bm) - (send c-bm set-loaded-mask m-bm) - (make-object image-snip% c-bm))) - - (values image-snip1 image-snip2))) - -(define image-snip3 (make-object image-snip%)) - -;; check-on-bitmap : symbol snip -> void -;; checks on various aspects of the bitmap snips to make -;; sure that they draw properly -(define (check-on-bitmap snp) - (let-values ([(width height) (send snp get-size)]) - (let ([bdc (make-object bitmap-dc%)] - [max-difference - (lambda (s1 s2) - (cond - [(and (zero? (bytes-length s1)) - (zero? (bytes-length s2))) - 0] - [else - (apply max - (map (lambda (x y) (abs (- x y))) - (bytes->list s1) - (bytes->list s1)))]))]) - - ;; test that no drawing is outside the snip's drawing claimed drawing area - (let* ([extra-space 100] - [bm-width (+ width extra-space)] - [bm-height (+ height extra-space)] - [bm-clip (make-object bitmap% bm-width bm-height)] - [bm-noclip (make-object bitmap% bm-width bm-height)] - [s-clip (make-bytes (* bm-width bm-height 4))] - [s-noclip (make-bytes (* bm-width bm-height 4))] - [s-trunc (make-bytes (* bm-width bm-height 4))]) - (send bdc set-bitmap bm-clip) - (send bdc clear) - (send bdc set-clipping-rect (/ extra-space 2) (/ extra-space 2) width height) - (send snp draw bdc (/ extra-space 2) (/ extra-space 2) 0 0 (+ width extra-space) (+ height extra-space) 0 0 #f) - (send bdc set-clipping-region #f) - (send bdc get-argb-pixels 0 0 (+ width extra-space) (+ height extra-space) s-clip) - - (send bdc set-bitmap bm-noclip) - (send bdc clear) - (send snp draw bdc (/ extra-space 2) (/ extra-space 2) 0 0 (+ width extra-space) (+ height extra-space) 0 0 #f) - (send bdc get-argb-pixels 0 0 (+ width extra-space) (+ height extra-space) s-noclip) - (send bdc set-bitmap #f) - - (check-equal? s-clip s-noclip) - - (send bdc set-bitmap bm-noclip) - (send bdc set-pen "black" 1 'transparent) - (send bdc set-brush "white" 'solid) - (send bdc draw-rectangle 0 0 (/ extra-space 2) bm-height) - (send bdc draw-rectangle (- bm-width (/ extra-space 2)) 0 (/ extra-space 2) bm-height) - (send bdc draw-rectangle 0 0 bm-width (/ extra-space 2)) - (send bdc draw-rectangle 0 (- bm-height (/ extra-space 2)) bm-width (/ extra-space 2)) - (send bdc get-argb-pixels 0 0 (+ width extra-space) (+ height extra-space) s-trunc) - - (check-equal? s-noclip s-trunc)) - - (let ([bm-normal (make-object bitmap% (max 1 width) (max 1 height))] - [bm-bitmap (make-object bitmap% (max 1 width) (max 1 height))] - [s-normal (make-bytes (* (max 1 width) (max 1 height) 4))] - [s-bitmap (make-bytes (* (max 1 width) (max 1 height) 4))]) - - (send bdc set-bitmap bm-normal) - (send bdc clear) - (send snp draw bdc 0 0 0 0 width height 0 0 #f) - (send bdc get-argb-pixels 0 0 width height s-normal) - (send bdc set-bitmap bm-bitmap) - (send bdc clear) - - ;; force the snip to switch over to bitmap mode - (send snp get-argb) - - (send snp draw bdc 0 0 0 0 width height 0 0 #f) - (send bdc get-argb-pixels 0 0 width height s-bitmap) - (send bdc set-bitmap #f) - (check-true (<= (max-difference s-normal s-bitmap) 2)))))) - -(define red (make-color 255 0 0)) -(define blue (make-color 0 0 255)) -(define black (make-color 0 0 0)) -(define white (make-color 255 255 255)) - -(define awhite (make-alpha-color 0 255 255 255)) -(define ablack (make-alpha-color 0 0 0 0)) -(define ared (make-alpha-color 0 255 0 0)) -(define aclr (make-alpha-color 255 0 0 0)) - -(define-simple-check (check-image=? i1 i2) - (image=? i1 i2)) - -(define-simple-check (check-not-image=? i1 i2) - (not (image=? i1 i2))) - -(define-simple-check (check-terminates val1) - #t) - -(define (add-line i x1 y1 x2 y2 color) - (overlay i - (line (image-width i) - (image-height i) - x1 y1 x2 y2 color) - "left" "top")) - -(define (not-image-inside? i1 i2) - (not (image-inside? i1 i2))) - -;; tests that the expression -;; a) raises a teachpack exception record, -;; b) has the right argument position, and -;; c) has the right name. -(define (tp-exn-pred name position) - (lambda (exn) - (and (exn:fail:contract? exn) - (let* ([msg (exn-message exn)] - [beg (format "~a:" name)] - [len (string-length beg)]) - (and (regexp-match position msg) - ((string-length msg) . > . len) - (string=? (substring msg 0 len) beg)))))) - -(define-syntax err/rt-name-test - (syntax-rules () - [(_ (name . args) position) - (check-exn (tp-exn-pred 'name position) - (lambda () - (name . args)))])) - -(define all-image-tests - (test-suite - "Tests for images" - - (test-case - "image?" - (check-pred image? (rectangle 10 10 'solid 'blue)) - (check-pred image? (rectangle 10 10 "solid" 'blue)) - (check-pred image? (rectangle 10 10 'outline 'blue)) - (check-pred image? (rectangle 10 10 "outline" 'blue)) - (check-false (image? 5))) - - (test-case - "color-list" - (check-equal? (list red) - (image->color-list (rectangle 1 1 'solid 'red))) - (check-equal? (list blue blue blue blue) - (image->color-list (rectangle 2 2 'solid 'blue)))) - - (test-case - "colors-set-up-properly" - (check-equal? (list (list red) (list blue) (list black) (list white)) - (list (image->color-list (rectangle 1 1 'solid 'red)) - (image->color-list (rectangle 1 1 'solid 'blue)) - (image->color-list (rectangle 1 1 'solid 'black)) - (image->color-list (rectangle 1 1 'solid 'white))))) - - (test-case - "color-list2" - (check-equal? (list blue blue blue - blue blue blue - blue blue blue) - (image->color-list (rectangle 3 3 'solid 'blue))) - (check-equal? (list blue blue blue - blue blue blue - blue blue blue) - (image->color-list (rectangle 3 3 "solid" 'blue))) - ;; Robby says: - ;; I think that this test just isn't one that the primitives guarantee to hold. - #;(check-equal? (list blue blue blue - blue white blue - blue blue blue) - (image->color-list (rectangle 3 3 'outline 'blue)))) - - - ;; Ditto. - #;(test-case - "color-list3" - (check-equal? (list blue blue blue - blue white blue - blue blue blue) - (image->color-list (rectangle 3 3 "outline" 'blue)))) - - (test-case - "color-list4" - (check-image=? (color-list->image (list blue blue blue blue) 2 2) - (rectangle 2 2 'solid 'blue))) - (test-case - "color-list5" - (check-not-image=? (color-list->image (list blue blue blue blue) 2 2) - (rectangle 1 4 'solid 'blue))) - - (test-case - "color-list6" - (check-image=? (color-list->image (list blue blue blue blue) 1 4) - (rectangle 1 4 'solid 'blue))) - (test-case - "color-list7" - (check-image=? (color-list->image (list 'blue 'blue 'blue 'blue) 2 2) - (rectangle 2 2 'solid 'blue))) - - (test-case - "color-list8" - (check-equal? 10 - (image-width (color-list->image '() 10 0)))) - - (test-case - "color-list9" - (check-equal? 0 - (image-height (color-list->image '() 10 0)))) - - (test-case - "color-list10" - (check-equal? 0 - (image-width (color-list->image '() 0 10)))) - - (test-case - "color-list11" - (check-equal? 10 - (image-height (color-list->image '() 0 10)))) - - (test-case - "alpha-color-list1" - (check-equal? (make-alpha-color 0 255 0 0) - (car (image->alpha-color-list (rectangle 1 1 'solid 'red))))) - - (test-case - "alpha-color-list2" - (check-equal? (make-alpha-color 0 255 0 0) - (car (image->alpha-color-list (rectangle 1 1 "solid" 'red))))) - - (test-case - "alpha-color-list3" - (for-each - (lambda (x) - (check-equal? x (make-alpha-color 0 255 0 0))) - (image->alpha-color-list (rectangle 1 1 "solid" 'red)))) - - (test-case - "alpha-color-list4" - (for-each - (lambda (x) - (check-equal? x (make-alpha-color 0 255 0 0))) - (image->alpha-color-list (rectangle 1 1 'solid 'red)))) - - (test-case - "alpha-color-list5" - (check-equal? (make-alpha-color 0 0 255 0) - (car (image->alpha-color-list (rectangle 1 1 'solid 'green))))) - - (test-case - "alpha-color-list6" - (check-equal? (make-alpha-color 0 0 0 255) - (car (image->alpha-color-list (rectangle 1 1 'solid 'blue))))) - - (test-case - "alpha-color-list7" - (check-equal? (image-width - (alpha-color-list->image - (list ared aclr ared - aclr aclr aclr) - 3 - 2)) - 3)) - (test-case - "alpha-color-list8" - (check-equal? (image-height - (alpha-color-list->image - (list ared aclr ared - aclr aclr aclr) - 3 - 2)) - 2)) - - (test-case - "alpha-color-list9" - (check-equal? (image->color-list - (alpha-color-list->image - (list ared aclr ared - aclr aclr aclr) - 3 2)) - (list red white red - white white white))) - (test-case - "alpha-color-list10" - (check-equal? (image->color-list - (overlay - (rectangle 3 3 'solid 'blue) - (alpha-color-list->image - (list ared aclr ared - aclr aclr aclr - ared aclr ared) - 3 3) - "left" "top")) - (list red blue red - blue blue blue - red blue red))) - - (test-case - "alpha-color-list11" - (check-equal? 10 (image-width (alpha-color-list->image '() 10 0)))) - - (test-case - "alpha-color-list12" - (check-equal? 0 (image-height (alpha-color-list->image '() 10 0)))) - - (test-case - "alpha-color-list13" - (check-equal? 0 (image-width (alpha-color-list->image '() 0 10)))) - - (test-case - "alpha-color-list14" - (check-equal? 10 (image-height (alpha-color-list->image '() 0 10)))) - - (test-case - "image=?1" - (check-image=? (alpha-color-list->image (list (make-alpha-color 200 100 150 175)) 1 1) - (alpha-color-list->image (list (make-alpha-color 200 100 150 175)) 1 1))) - - (test-case - "image=?2" - (check-image=? (alpha-color-list->image (list (make-alpha-color 255 100 100 100)) 1 1) - (alpha-color-list->image (list (make-alpha-color 255 200 200 200)) 1 1))) - - (test-case - "image=?3" - (check-not-image=? (alpha-color-list->image (list (make-alpha-color 200 100 100 100)) 1 1) - (alpha-color-list->image (list (make-alpha-color 200 200 200 200)) 1 1))) - - (test-case - "image=?4" - (check-not-image=? (alpha-color-list->image (list (make-alpha-color 200 100 150 175) - (make-alpha-color 200 100 150 175)) - 1 - 2) - (alpha-color-list->image (list (make-alpha-color 200 100 150 175) - (make-alpha-color 200 100 150 175)) - 2 - 1))) - - ;; This one is broken because of a fundamental problem with the - ;; image primitives. - #;(test-case - "image=?5" - (check-not-image=? (rectangle 4 4 'outline 'black) - (overlay - (rectangle 4 4 'outline 'black) - (circle 1 'solid 'red) - 0 0))) - - (test-case - "overlay" - (check-image=? (color-list->image (list blue red blue red) 2 2) - (overlay (rectangle 2 2 'solid 'red) - (rectangle 1 2 'solid 'blue) - "left" "top"))) - - (test-case - "overlay/multiple" - (check-image=? (overlay (rectangle 6 6 'solid 'red) - (overlay (rectangle 4 4 'solid 'white) - (rectangle 2 2 'solid 'blue) - "center" "center") - "center" "center") - (overlay (overlay (rectangle 6 6 'solid 'red) - (rectangle 4 4 'solid 'white) - "center" "center") - (rectangle 2 2 'solid 'blue) - "center" "center"))) - - (test-case - "overlay/empty-spaces-are-unmasked" - (check-image=? (color-list->image (list red red red blue) 2 2) - (overlay - (rectangle 2 2 'solid 'blue) - (overlay (rectangle 1 2 'solid 'red) - (rectangle 2 1 'solid 'red) - "left" "top") - "left" "top"))) - - (test-case - "overlay/xy1" - (check-image=? (color-list->image (list red blue red blue) 2 2) - (overlay (rectangle 2 2 'solid 'red) - (rectangle 1 2 'solid 'blue) - 1 0))) - - (test-case - "overlay/xy2" - (check-image=? (color-list->image (list red red red blue) 2 2) - (overlay (rectangle 2 2 'solid 'red) - (rectangle 1 1 'solid 'blue) - 1 1))) - - (test-case - "overlay/xy3" - (check-image=? (color-list->image (list red red blue blue) 2 2) - (overlay (rectangle 2 1 'solid 'red) - (rectangle 2 1 'solid 'blue) - 0 1))) - - (test-case - "overlay/xy/white" - (check-image=? (alpha-color-list->image (list ablack ablack ablack - ablack awhite ablack - ablack ablack ablack) - 3 3) - (overlay (rectangle 3 3 'solid 'black) - (rectangle 1 1 'solid 'white) - 1 1))) - - (test-case - "color-list->image/white-in-mask" - (check-image=? (color-list->image (list black red black - red red red - black red black) - 3 3) - (overlay (rectangle 3 3 'solid 'red) - (color-list->image (list black white black - white white white - black white black) - 3 3) - "left" "top"))) - - - (test-case - "overlay" - (check-image=? (color-list->image (list red blue red red blue red) 3 2) - (overlay (rectangle 3 2 'solid 'red) - (rectangle 1 2 'solid 'blue) - 1 0))) - - (test-case - "image=?-zero1" - (check-image=? (rectangle 0 10 'solid 'red) - (rectangle 0 10 'solid 'red))) - (test-case - "image=?-zero2" - (check-image=? (rectangle 0 10 'solid 'red) - (rectangle 0 10 'solid 'blue))) - (test-case - "image=?-zero3" - (check-not-image=? (rectangle 0 5 'solid 'red) - (rectangle 0 4'solid 'blue))) - - (test-case - "image-inside?1" - (check image-inside? - (overlay (rectangle 3 2 'solid 'red) - (rectangle 1 2 'solid 'blue) - 1 0) - (rectangle 1 2 'solid 'blue))) - - (test-case - "image-inside?2" - (check not-image-inside? - (overlay (rectangle 3 2 'solid 'red) - (rectangle 1 2 'solid 'blue) - 1 0) - (rectangle 1 2 'solid 'black))) - - (test-case - "image-inside?3" - (check image-inside? - (overlay (rectangle 3 2 'solid 'red) - (rectangle 1 2 'solid 'blue) - 1 0) - (rectangle 1 2 'solid 'red))) - - (test-case - "image-inside?4" - (check not-image-inside? - (overlay (rectangle 3 2 'solid 'red) - (rectangle 1 2 'solid 'blue) - 1 0) - (rectangle 2 1 'solid 'red))) - - (test-case - "image-inside?5" - (check image-inside? - (alpha-color-list->image (list (make-alpha-color 0 255 0 0)) 1 1) - (alpha-color-list->image (list (make-alpha-color 255 0 0 0)) 1 1))) - - (test-case - "image-inside?6" - (check not-image-inside? - (overlay (rectangle 3 2 'solid 'red) - (rectangle 1 2 'solid 'blue) - 1 0) - (color-list->image (list blue white white) - 3 1))) - - (test-case - "image-inside?7" - (check image-inside? - (overlay (rectangle 16 16 'solid 'red) - (ellipse 6 6 'outline 'blue) - 2 5) - (ellipse 6 6 'outline 'blue))) - - (test-case - "image-inside?8" - (check image-inside? - (overlay (rectangle (image-width (text "x" 12 'red)) - (image-height (text "x" 12 'red)) - 'solid - 'white) - (text "x" 12 'red) - "center" "center") - (text "x" 12 'red))) - - (test-case - "image-inside?9" - (check image-inside? - (text "y x y" 12 'red) - (text "x" 12 'red))) - - (test-case - "find-image1" - (check-equal? (make-posn 2 5) - (find-image (overlay (rectangle 16 16 'solid 'red) - (ellipse 6 6 'outline 'blue) - 2 5) - (ellipse 6 6 'outline 'blue)))) - - (test-case - "find-image2" - (check-equal? (make-posn 0 0) - (find-image (rectangle 16 16 'solid 'blue) - (ellipse 6 6 'outline 'blue)))) - - (test-case - "find-image3" - (check-equal? (make-posn 1 1) - (find-image (overlay (rectangle 10 10 'solid 'blue) - (ellipse 5 5 'solid 'red) - 1 1) - (ellipse 5 5 'solid 'red)))) - - (test-case - "image-width" - (check-equal? 5 (image-width (rectangle 5 7 'solid 'red)))) - - (test-case - "image-height" - (check-equal? 7 (image-height (rectangle 5 7 'solid 'red)))) - - (test-case - "color-red" - (check-equal? 1 (color-red (make-color 1 2 3)))) - - (test-case - "color-green" - (check-equal? 2 (color-green (make-color 1 2 3)))) - - (test-case - "color-blue" - (check-equal? 3 (color-blue (make-color 1 2 3)))) - - (test-case - "color?1" - (check-true (color? (make-color 1 2 3)))) - - (test-case - "color?2" - (check-false (color? 10))) - - (test-case - "image-color?1" - (check-pred image-color? (make-color 1 2 3))) - - (test-case - "image-color?2" - (check-pred image-color? "blue")) - - (test-case - "image-color?3" - (check-pred image-color? 'blue)) - - (test-case - "image-color?4" - (check-false (image-color? 10))) - - (test-case - "image-color?5" - (check-false (image-color? "not-a-color"))) - - (test-case - "image-color?6" - (check-false (image-color? 'not-a-color))) - - (test-case - "line" - (check image=? - (line 5 1 0 0 4 0 'red) - (color-list->image (list red red red red red) 5 1)) - (check image=? - (line 1 5 0 0 0 4 'red) - (color-list->image (list red red red red red) 1 5)) - - (check image=? - (line 1 5 0 4 0 0 'red) - (color-list->image (list red red red red red) 1 5)) - - (check image=? - (line 5 1 4 0 0 0 'red) - (color-list->image (list red red red red red) 5 1))) - - -; note: next two tests may be platform-specific... I'm not sure. - ;; I developed them under macos x. -robby - ;; And sure enough, this one doesn't work anymore. -Mike - #;(test-case - "triangle1" - (check image=? - (triangle 3 'outline 'red) - (color-list->image - (list white red white - white red white - red white red - red red red) - 3 - 4))) - - (test-case - "triangle2" - (check image=? - (triangle 3 'solid 'red) - (color-list->image - (list white red white - white red white - red red red - red red red) - 3 - 4))) - - (test-case - "clipping-twice-clips-both-times" - (check image=? - (overlay - (rectangle 11 11 'solid 'green) - (clip (rectangle 11 11 'solid 'red) - 5 5 1 1) - "center" "center") - (overlay - (rectangle 11 11 'solid 'green) - (clip (clip (rectangle 11 11 'solid 'red) - 3 3 2 2) - 2 2 1 1) - "center" "center"))) - - (test-case - "solid-rect" - (check-on-bitmap (rectangle 2 2 'solid 'red))) - - (test-case - "outline-rect" - (check-on-bitmap (rectangle 2 2 'outline 'red))) - (test-case - "solid-ellipse" - (check-on-bitmap (ellipse 2 4 'solid 'red))) - (test-case - "outline-ellipse" - (check-on-bitmap (ellipse 2 4 'outline 'red))) - (test-case - "solid-circle" - (check-on-bitmap (circle 4 'solid 'red))) - (test-case - "outline-circle" - (check-on-bitmap (circle 4 'outline 'red))) - - (test-case - "0solid-rect1" - (check-on-bitmap (rectangle 0 2 'solid 'red))) - (test-case - "0solid-rect2" - (check-on-bitmap (rectangle 2 0 'solid 'red))) - (test-case - "0outline-rect1" - (check-on-bitmap (rectangle 2 0 'outline 'red))) - (test-case - "0outline-rect2" - (check-on-bitmap (rectangle 0 0 'outline 'red))) - (test-case - "0solid-ellipse1" - (check-on-bitmap (ellipse 0 3 'solid 'red))) - (test-case - "0solid-ellipse2" - (check-on-bitmap (ellipse 3 0 'solid 'red))) - (test-case - "0outline-ellipse1" - (check-on-bitmap (ellipse 0 4 'outline 'red))) - (test-case - "0outline-ellipse2" - (check-on-bitmap (ellipse 2 0 'outline 'red))) - (test-case - "0solid-circle" - (check-on-bitmap (circle 0 'solid 'red))) - (test-case - "0outline-circle" - (check-on-bitmap (circle 0 'outline 'red))) - - (test-case - "solid-triangle" - (check-on-bitmap (triangle 10 'solid 'red))) - (test-case - "outline-triangle" - (check-on-bitmap (triangle 10 'outline 'red))) - (test-case - "line" - (check-on-bitmap (line 10 7 0 0 9 6 'red))) - - - - ;; (check-on-bitmap 'text (text "XX" 12 'red)) ;; this test fails for reasons I can't control ... -robby - (test-case - "overlay1" - (check-on-bitmap (overlay (rectangle 1 4 'solid 'blue) - (rectangle 4 1 'solid 'green) - "left" "top"))) - (test-case - "overlay2" - (check-on-bitmap (overlay (rectangle 4 4 'solid 'blue) - (rectangle 4 4 'solid 'green) - 2 2))) - (test-case - "overlay3" - (check-on-bitmap (overlay image-snip1 - (rectangle (image-width image-snip1) - (image-height image-snip1) - 'outline - 'red) - "center" "center"))) - (test-case - "alpha-color-list" - (check-on-bitmap - (overlay - (rectangle 3 3 'solid 'blue) - (alpha-color-list->image - (list ared aclr ared - aclr aclr aclr - ared aclr ared) - 3 - 3) - "center" "center"))) - (test-case - "add-line" - (check-on-bitmap - (overlay - (rectangle 100 100 'solid 'black) - (line 100 100 -10 -10 110 110 'red) - 0 0))) - - (test-case - "add-line1" - (check-on-bitmap - (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") - -20 -20 - 0 0 - 'red))) - (test-case - "add-line2" - (check-on-bitmap - (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") - -20 20 - 0 0 - 'red))) - (test-case - "add-line3" - (check-on-bitmap - (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") - 20 -20 - 0 0 - 'red))) - - (test-case - "add-line4" - (check-on-bitmap - (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") - 20 20 - 0 0 - 'red))) - - (test-case - "add-line5" - (check-on-bitmap - (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") - 0 0 - -20 -20 - 'red))) - - (test-case - "add-line6" - (check-on-bitmap - (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") - 0 0 - -20 20 - 'red))) - - (test-case - "add-line7" - (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") - 0 0 - 20 -20 - 'red)) - - (test-case - "add-line8" - (check-on-bitmap - (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") - 0 0 - 20 20 - 'red))) - - (test-case - "shrink" - (check-on-bitmap - (clip (rectangle 11 11 'solid 'red) - 5 5 1 1))) - - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; test images with zero width or zero height - ;; for various things - ;; - - (test-case - "zero-width/height" - (check-equal? 10 (image-width (rectangle 10 0 'solid 'red))) - (check-equal? 0 (image-height (rectangle 10 0 'solid 'red))) - (check-equal? 0 (image-width (rectangle 0 10 'solid 'red))) - (check-equal? 10 (image-height (rectangle 0 10 'solid 'red))) - - (check-equal? 0 (image-width (text "" 12 'black))) - (check > (image-height (text "" 12 'black)) 0) - - (check-equal? '() (image->color-list (rectangle 0 10 'solid 'red))) - (check-equal? '() (image->color-list (rectangle 10 0 'solid 'red))) - (check-equal? '() (image->color-list (rectangle 0 0 'solid 'red))) - - (check-equal? '() (image->alpha-color-list (rectangle 0 10 'solid 'red))) - (check-equal? '() (image->alpha-color-list (rectangle 10 0 'solid 'red))) - (check-equal? '() (image->alpha-color-list (rectangle 0 0 'solid 'red)))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; test that the image construction functions - ;; accept non-integer values (and floor them) - ;; - - (test-case - "accept-non-integer" - (check-equal? (image->color-list (rectangle 2 2 'solid 'blue)) - (image->color-list (rectangle #e2.5 2.5 'solid 'blue))) - (check-equal? (image->color-list (ellipse 2 2 'solid 'blue)) - (image->color-list (ellipse #e2.5 2.5 'solid 'blue))) - (check-equal? (image->color-list (circle 2 'solid 'blue)) - (image->color-list (circle #e2.5 'solid 'blue))) - (check-equal? (image->color-list (triangle 12 'solid 'blue)) - (image->color-list (triangle 12.5 'solid 'blue))) - (check-equal? (image->color-list (line 10 12 0 0 9 11 'blue)) - (image->color-list (line 10 12 0 0 9.5 #e11.5 'blue))) - (check-equal? (image->color-list (clip (rectangle 10 10 'solid 'blue) 3 3 4 4)) - (image->color-list - (clip (rectangle 10 10 'solid 'blue) - 3.1 - 3.2 - #e4.3 - 4.4))) - (check-equal? (image->color-list (add-line (rectangle 10 10 'solid 'blue) - 0 0 2 2 'red)) - (image->color-list (add-line (rectangle 10 10 'solid 'blue) - 0.1 #e.2 2.1 2.2 'red)))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; The tests beginning with "bs-" ensure - ;; that the operations all can accept bitmap - ;; snips as arguments - ;; - - (test-case - "accept-bitmap" - (check-pred image? image-snip1) - (check-pred image? image-snip2) - (check image=? image-snip1 (send image-snip1 copy)) - (check-not-image=? - ;; They have different masks: - image-snip1 image-snip2) - (check-equal? 2 (image-width image-snip1)) - (check-equal? 2 (image-width image-snip2)) - (check-equal? 2 (image-height image-snip1)) - (check-equal? 2 (image-height image-snip2)) - (check image=? image-snip1 (overlay image-snip1 image-snip2 "center" "center")) - (check image=? image-snip1 (overlay image-snip1 image-snip2 "left" "top")) - (check image=? - (add-line image-snip1 0 0 10 10 'green) - (add-line image-snip2 0 0 10 10 'green)) - (check image-inside? image-snip1 image-snip2) - (check image-inside? image-snip2 image-snip1) - (check-equal? (make-posn 0 0) - (find-image image-snip1 image-snip2)) - (check-equal? (make-posn 0 0) - (find-image image-snip2 image-snip1)) - (check-equal? (image->color-list image-snip1) - (image->color-list image-snip2)) - (check-equal? (image->alpha-color-list image-snip1) - (image->alpha-color-list image-snip2))) - - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; test image-snip that doesnt' have a bitmap - ;; - - (test-case - "image-snip-no-bitmap" - (check-equal? 20 - (image-width image-snip3)) - (overlay image-snip3 image-snip3 10 10)) - - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; test color arguments - ;; - (test-case - "color-arguments" - (check-terminates (rectangle 10 10 'solid 'blue)) - (check-terminates (rectangle 10 10 'solid "blue")) - (check-terminates (rectangle 10 10 'solid (make-color 0 0 255))) - (check-terminates (ellipse 10 10 'solid 'blue)) - (check-terminates (ellipse 10 10 'solid "blue")) - (check-terminates (ellipse 10 10 'solid (make-color 0 0 255))) - (check-terminates (circle 10 'solid 'blue)) - (check-terminates (circle 10 'solid "blue")) - (check-terminates (circle 10 'solid (make-color 0 0 255))) - (check-terminates (triangle 10 'solid 'blue)) - (check-terminates (triangle 10 'solid "blue")) - (check-terminates (triangle 10 'solid (make-color 0 0 255))) - (check-terminates (line 10 10 0 0 9 9 'blue)) - (check-terminates (line 10 10 0 0 9 9 "blue")) - (check-terminates (line 10 10 0 0 9 9 (make-color 0 0 255))) - (check-terminates (add-line (rectangle 1 1 'solid 'blue) 0 0 1 1 'blue)) - (check-terminates (add-line (rectangle 1 1 'solid 'blue) 0 0 1 1 "blue")) - (check-terminates (add-line (rectangle 1 1 'solid 'blue) 0 0 1 1 (make-color 0 0 255))) - (check-terminates (text "abc" 12 'blue)) - (check-terminates (text "abc" 12 "blue")) - (check-terminates (text "abc" 12 (make-color 0 0 255)))) - - (test-case - "error-message" - (err/rt-name-test (image-width 1) "first") - (err/rt-name-test (image-height 1) "first") - (err/rt-name-test (overlay 1 2 "center" "center") "first") - (err/rt-name-test (overlay image-snip1 2 "center" "center") "second") - (err/rt-name-test (overlay 1 2 "center" "center") "first") - (err/rt-name-test (overlay image-snip1 image-snip2 "foo" "center") "third") - (err/rt-name-test (overlay image-snip1 image-snip2 "center" "foo") "fourth") - (err/rt-name-test (rectangle #f #f #f #f) "first") - (err/rt-name-test (rectangle 10 #f #f #f) "second") - (err/rt-name-test (rectangle 10 10 #f #f) "third") - (err/rt-name-test (rectangle 10 10 'solid #f) "fourth") - (err/rt-name-test (circle #f #f #f) "first") - (err/rt-name-test (circle 10 #f #f) "second") - (err/rt-name-test (circle 10 'solid #f) "third") - (err/rt-name-test (ellipse #f #f #f #f) "first") - (err/rt-name-test (ellipse 10 #f #f #f) "second") - (err/rt-name-test (ellipse 10 10 #f #f) "third") - (err/rt-name-test (ellipse 10 10 'solid #f) "fourth") - (err/rt-name-test (triangle #f #f #f) "first") - (err/rt-name-test (triangle 10 #f #f) "second") - (err/rt-name-test (triangle 10 'solid #f) "third") - (err/rt-name-test (line #f #f 0 0 0 0 #f) "first") - (err/rt-name-test (line 10 #f 0 0 0 0 #f) "second") - (err/rt-name-test (line 10 10 #f 0 0 0 #f) "third") - (err/rt-name-test (line 10 10 0 #f 0 0 #f) "fourth") - (err/rt-name-test (line 10 10 0 0 #f 0 #f) "fifth") - (err/rt-name-test (line 10 10 0 0 0 #f #f) "sixth") - (err/rt-name-test (line 10 10 0 0 0 0 #f) "seventh") - (err/rt-name-test (text #f #f #f) "first") - (err/rt-name-test (text "abc" #f #f) "second") - (err/rt-name-test (text "abc" 10 #f) "third") - (err/rt-name-test (image-inside? #f #f) "first") - (err/rt-name-test (image-inside? image-snip1 #f) "second") - (err/rt-name-test (find-image #f #f) "first") - (err/rt-name-test (find-image image-snip1 #f) "second") - (err/rt-name-test (image->color-list 1) "first") - (err/rt-name-test (color-list->image #f #f #f) "first") - (err/rt-name-test (color-list->image (list (make-color 0 0 0)) #f #f) "second") - (err/rt-name-test (color-list->image (list (make-color 0 0 0)) 1 #f) "third") - (err/rt-name-test (image->alpha-color-list #f) "first") - (err/rt-name-test (alpha-color-list->image #f #f #f) "first") - (err/rt-name-test (alpha-color-list->image (list (make-alpha-color 0 0 0 0)) #f #f) "second") - (err/rt-name-test (alpha-color-list->image (list (make-alpha-color 0 0 0 0)) 1 #f) "third")) -)) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/tests/match.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/tests/match.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/tests/match.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/tests/match.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,114 +0,0 @@ -#lang racket/base - -(provide all-match-tests) - -(require rackunit - deinprogramm/define-record-procedures - (only-in deinprogramm/DMdA match empty make-pair)) - -(define-record-procedures pare - kons pare? - (kar kdr)) - -(define-record-procedures bare - gons bare? - (gar gdr)) - -(define-record-procedures nullary - make-nullary nullary? - ()) - -(define all-match-tests - (test-suite - "Tests for DeinProgramm match form." - - (test-case - "literals" - (define foo - (lambda (x) - (match x - (#t 'true) - (#f 'false) - ('() 'nil) - ('(foo bar) 'foobar) - ("foo" 'foo) - ("bar" 'bar) - (5 'five) - (2 'two)))) - - (check-equal? (foo #t) 'true) - (check-equal? (foo #f) 'false) - (check-equal? (foo '()) 'nil) - (check-equal? (foo '(foo bar)) 'foobar) - (check-equal? (foo "foo") 'foo) - (check-equal? (foo "bar") 'bar) - (check-equal? (foo 5) 'five) - (check-equal? (foo 2) 'two)) - - - (test-case - "variables" - (define foo - (lambda (x) - (match x - (#t 'true) - (foo (list 'foo foo))))) - (check-equal? (foo #t) 'true) - (check-equal? (foo "foo") '(foo "foo"))) - - (test-case - "lists" - (define foo - (lambda (x) - (match x - (empty 'empty) - ((make-pair 'foo empty) 'fooempty) - ((list 'foo 'bar) 'listfoobar) - ((list 'bar 'foo) 'listbarfoo) - ((list a b c) (list 'list a b c)) - ((make-pair 5 b) (list 'make-pair5 b)) - ((make-pair a (make-pair b c)) (list 'make-pair a b c)) - ((make-pair a b) (list 'make-pair a b)) - (x (list 'x x))))) - - (check-equal? (foo empty) 'empty) - (check-equal? (foo "empty") '(x "empty")) - (check-equal? (foo (list 1 2 3)) '(list 1 2 3)) - (check-equal? (foo (make-pair 'foo empty)) 'fooempty) - (check-equal? (foo (make-pair 1 empty)) '(make-pair 1 ())) - (check-equal? (foo (make-pair 5 empty)) '(make-pair5 ())) - (check-equal? (foo (list 1 2)) '(make-pair 1 2 ())) - (check-equal? (match empty ((list) 'bingo)) 'bingo) - (check-equal? (match (list 1) ((list) 'bingo) (foo foo)) (list 1)) - (check-equal? (foo (list 'foo 'bar)) 'listfoobar) - (check-equal? (foo (list 'bar 'foo)) 'listbarfoo)) - - (test-case - "anything" - (check-equal? (match 5 (_ 7)) 7) - (check-equal? (match '(1 2) (_ 7)) 7) - (check-equal? (match #f (_ 7)) 7) - (check-equal? (let ((_ 5)) (match #f (_ _))) 5) - (check-equal? (match #f - ((kons _ _) 7) - (_ 5)) - 5) - (check-equal? (match (kons 1 2) - ((kons _ _) 7) - (_ 5)) - 7)) - - (test-case - "records" - (define foo - (lambda (x) - (match x - ((make-pair foo empty) 'pairfoo) - ((make-nullary) 'nullary) - ((kons a b) (list 'kons a b)) - ((gons a b) (list 'gons a b))))) - - (check-equal? (foo (make-pair foo empty)) 'pairfoo) - (check-equal? (foo (make-nullary)) 'nullary) - (check-equal? (foo (kons 1 2)) '(kons 1 2)) - (check-equal? (foo (gons 1 2)) '(gons 1 2))))) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/tests/record.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/tests/record.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/tests/record.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/tests/record.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,105 +0,0 @@ -#lang racket/base - -(provide all-record-tests) - -(require rackunit - deinprogramm/define-record-procedures - racket/match) - -(define-record-procedures pare - kons pare? - (kar kdr)) - -(define-record-procedures paire - koins - (kair kdir)) - -(define-record-procedures chocolate-cookie - make-chocolate-cookie chocolate-cookie? - (chocolate-cookie-chocolate chocolate-cookie-cookie)) - -(define-record-procedures-2 mpare - mkons mpare? - ((mkar set-mkar!) mkdr)) - -(define-record-procedures-parametric ppare pkons-of - pkons pkons? - (pkar pkdr)) - -(define-record-procedures-parametric-2 pmpare pmkons-of - pmkons pmkons? - ((pmkar set-pmkar!) pmkdr)) - -(define all-record-tests - (test-suite - "Tests for DeinProgramm records." - - (test-case - "basics" - (define p1 (kons 1 2)) - (define p2 (kons 3 4)) - - (check-true (pare? p1)) - (check-true (pare? p2)) - - (check-false (pare? 5)) - (check-false (pare? (make-chocolate-cookie 1 2))) - - (check-equal? (kar p1) 1) - (check-equal? (kdr p1) 2) - (check-equal? (kar p2) 3) - (check-equal? (kdr p2) 4)) - - (test-case - "no predicate" - - (define p1 (koins 1 2)) - (define p2 (koins 3 4)) - - (check-equal? (kair p1) 1) - (check-equal? (kdir p1) 2) - (check-equal? (kair p2) 3) - (check-equal? (kdir p2) 4)) - - (test-case - "matching" - (define p (kons 1 2)) - (define c (make-chocolate-cookie 3 4)) - - (define t - (lambda (r) - (match r - ((kons a b) (list 'kons a b)) - ((make-chocolate-cookie ch ck) (list 'make-chocolate-cookie ch ck))))) - - (check-equal? (t p) '(kons 1 2)) - (check-equal? (t c) '(make-chocolate-cookie 3 4))) - - (test-case - "-2" - (define p (mkons 1 2)) - - (check-equal? (mkar p) 1) - (check-equal? (mkdr p) 2) - - (set-mkar! p 5) - - (check-equal? (mkar p) 5)) - - (test-case - "-parametric" - (define p (pkons 1 2)) - - (check-equal? (pkar p) 1) - (check-equal? (pkdr p) 2)) - - (test-case - "-parametric-2" - (define p (pmkons 1 2)) - - (check-equal? (pmkar p) 1) - (check-equal? (pmkdr p) 2) - - (set-pmkar! p 5) - - (check-equal? (pmkar p) 5)))) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/tests/run-image-test.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/tests/run-image-test.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/tests/run-image-test.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/tests/run-image-test.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,6 +0,0 @@ -#lang scheme/base - -(require rackunit/text-ui) -(require deinprogramm/tests/image) - -(run-tests all-image-tests) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/tests/run-match-tests.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/tests/run-match-tests.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/tests/run-match-tests.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/tests/run-match-tests.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,6 +0,0 @@ -#lang racket/base - -(require rackunit/text-ui) -(require deinprogramm/tests/match) - -(run-tests all-match-tests) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/tests/run-record-tests.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/tests/run-record-tests.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/tests/run-record-tests.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/tests/run-record-tests.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,6 +0,0 @@ -#lang racket/base - -(require rackunit/text-ui) -(require deinprogramm/tests/record) - -(run-tests all-record-tests) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/tests/run-signature-tests.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/tests/run-signature-tests.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/tests/run-signature-tests.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/tests/run-signature-tests.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,6 +0,0 @@ -#lang scheme/base - -(require rackunit/text-ui) -(require deinprogramm/tests/signature) - -(run-tests all-signature-tests) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/tests/signature.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/tests/signature.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/tests/signature.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/tests/signature.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,645 +0,0 @@ -#lang scheme/base - -(provide all-signature-tests) - -(require rackunit - deinprogramm/define-record-procedures - deinprogramm/signature/signature - deinprogramm/signature/signature-german - deinprogramm/signature/signature-syntax) - -(require scheme/promise) - -(define integer (make-predicate-signature 'integer integer? 'integer-marker)) -(define boolean (make-predicate-signature 'boolean boolean? 'boolean-marker)) -(define %a (make-type-variable-signature 'a 'a-marker)) -(define %b (make-type-variable-signature 'b 'b-marker)) - -(define-syntax say-no - (syntax-rules () - ((say-no ?body ...) - (let/ec exit - (call-with-signature-violation-proc - (lambda (obj signature message blame) - (exit 'no)) - (lambda () - ?body ...)))))) - -(define-syntax failed-signature - (syntax-rules () - ((say-no ?body ...) - (let/ec exit - (call-with-signature-violation-proc - (lambda (obj signature message blame) - (exit signature)) - (lambda () - ?body ...)))))) - -(define signature-tests - (test-suite - "Tests for signature combinators" - - (test-case - "flat" - (check-equal? (say-no (apply-signature integer 5)) 5) - (check-equal? (say-no (apply-signature integer "foo")) 'no)) - - (test-case - "list" - (define integer-list (make-list-signature 'integer-list integer #f)) - (check-equal? (say-no (apply-signature integer-list '(1 2 3))) - '(1 2 3)) - (check-equal? (say-no (apply-signature integer-list '#f)) - 'no) - (check-eq? (failed-signature (apply-signature integer-list '(1 #f 3))) - integer)) - - (test-case - "list-cached" - (define integer-list (make-list-signature 'integer-list integer #f)) - (define boolean-list (make-list-signature 'integer-list boolean #f)) - (define l '(1 2 3)) - (define foo "foo") - (define no '(1 #f 3)) - (define no2 '(1 #f 3)) - (define integer-list->bool (make-procedure-signature 'integer-list->bool (list integer-list) boolean 'int->bool-marker)) - - (check-equal? (say-no (apply-signature integer-list l)) - '(1 2 3)) - (check-equal? (say-no (apply-signature integer-list l)) - '(1 2 3)) - (check-equal? (say-no (apply-signature boolean-list l)) - 'no) - (check-equal? (say-no (apply-signature integer-list foo)) - 'no) - (check-equal? (say-no (apply-signature integer-list foo)) - 'no) - (check-eq? (failed-signature (apply-signature integer-list no)) - integer) - (check-eq? (failed-signature (apply-signature integer-list no)) - integer) - - (let ((proc (say-no (apply-signature integer-list->bool (lambda (l) (even? (car l))))))) - (check-equal? (say-no (proc no)) 'no) - (check-equal? (say-no (proc no)) 'no) - (check-equal? (say-no (proc no2)) 'no) - (check-equal? (say-no (proc no2)) 'no)) - ) - - (test-case - "vector" - (define integer-vector (make-vector-signature 'integer-vector integer #f)) - (define a-vector (make-vector-signature 'a-vector %a #f)) - (check-equal? (say-no (apply-signature integer-vector '#(1 2 3))) - '#(1 2 3)) - (check-equal? (say-no (apply-signature a-vector '#(1 2 3))) - '#(1 2 3)) - (check-equal? (say-no (apply-signature integer-vector '#f)) - 'no) - (check-eq? (failed-signature (apply-signature integer-vector '#(1 #f 3))) - integer)) - - (test-case - "vector/cached" - (let ((count 0)) - (define counting-integer - (make-predicate-signature 'counting-integer - (lambda (obj) - (set! count (+ 1 count)) - (integer? obj)) - 'integer-marker)) - - (define integer-vector (make-vector-signature 'integer-list counting-integer #f)) - - (define v1 '#(1 2 3)) - - (check-eq? (say-no (apply-signature integer-vector v1)) - v1) - (check-equal? count 3) - (check-eq? (say-no (apply-signature integer-vector v1)) - v1) - (check-equal? count 3))) - - - (test-case - "mixed" - (define int-or-bool (make-mixed-signature 'int-or-bool - (list integer - boolean) - 'int-or-bool-marker)) - (check-equal? (say-no (apply-signature int-or-bool #f)) - #f) - (check-equal? (say-no (apply-signature int-or-bool 17)) - 17) - (check-equal? (say-no (apply-signature int-or-bool "foo")) - 'no)) - - (test-case - "combined" - (define octet (make-combined-signature - 'octet - (list - integer - (make-predicate-signature '<256 - (delay (lambda (x) - (< x 256))) - '<256-marker) - (make-predicate-signature 'non-negative - (delay (lambda (x) - (>= x 0))) - 'non-negative-marker)) - 'octet-marker)) - (check-equal? (say-no (apply-signature octet #f)) - 'no) - (check-equal? (say-no (apply-signature octet 17)) - 17) - (check-equal? (say-no (apply-signature octet 0)) - 0) - (check-equal? (say-no (apply-signature octet -1)) - 'no) - (check-equal? (say-no (apply-signature octet 255)) - 255) - (check-equal? (say-no (apply-signature octet 256)) - 'no) - (check-equal? (say-no (apply-signature octet "foo")) - 'no)) - - (test-case - "case" - (define foo-or-bar (make-case-signature 'foo-or-bar '("foo" "bar") equal? 'foo-or-bar-marker)) - (check-equal? (say-no (apply-signature foo-or-bar #f)) - 'no) - (check-equal? (say-no (apply-signature foo-or-bar "foo")) - "foo") - (check-equal? (say-no (apply-signature foo-or-bar "bar")) - "bar")) - - (test-case - "procedure" - (define int->bool (make-procedure-signature 'int->bool (list integer) boolean 'int->bool-marker)) - (check-equal? (say-no (apply-signature int->bool #f)) - 'no) - (check-equal? (say-no (apply-signature int->bool (lambda () "foo"))) - 'no) - (check-equal? (say-no (apply-signature int->bool (lambda (x y) "foo"))) - 'no) - (let ((proc (say-no (apply-signature int->bool (lambda (x) (odd? x)))))) - (check-pred procedure? proc) - (check-equal? (proc 15) #t) - (check-equal? (proc 16) #f) - (check-equal? (say-no (proc "foo")) 'no)) - (let ((proc (say-no (apply-signature int->bool (lambda (x) (+ x 1)))))) - (check-equal? (say-no (proc 12)) 'no))) - - (test-case - "type variable - simple" - (check-equal? (say-no (apply-signature %a #f)) #f) - (check-equal? (say-no (apply-signature %a 15)) 15)) - - (test-case - "type variable - list" - (define a-list (make-list-signature 'a-list %a #f)) - (check-equal? (say-no (apply-signature a-list '(1 2 3))) - '(1 2 3)) - (check-equal? (say-no (apply-signature a-list '#f)) - 'no) - (check-equal? (say-no (apply-signature a-list '(#f "foo" 5))) - '(#f "foo" 5))) - - (test-case - "apply-signature/blame" - (define int->bool (make-procedure-signature 'int->bool (list integer) boolean 'int->bool-marker)) - (let ((proc (say-no (apply-signature/blame int->bool (lambda (x) (odd? x)))))) - (check-pred procedure? proc) - (check-equal? (proc 15) #t) - (check-equal? (proc 16) #f) - (check-equal? (say-no (proc "foo")) 'no)) - (let ((proc (say-no (apply-signature/blame int->bool (lambda (x) x))))) - (call-with-signature-violation-proc - (lambda (obj signature message blame) - (check-true (syntax? blame))) - (lambda () - (proc 5))))) - )) - -(define signature-syntax-tests - (test-suite - "Tests for signature syntax" - - (test-case - "predicate" - (define integer (signature (predicate integer?))) - (check-equal? (say-no (apply-signature integer 5)) 5) - (check-equal? (say-no (apply-signature integer "foo")) 'no)) - - (test-case - "list" - (check-equal? (say-no (apply-signature (signature x (list-of %a)) 5)) 'no) - (check-equal? (say-no (apply-signature (signature x (list-of %a)) '(1 2 3))) '(1 2 3)) - (check-equal? (say-no (apply-signature (signature x (list-of (predicate integer?))) '(1 2 3))) '(1 2 3)) - (check-equal? (say-no (apply-signature (signature x (list-of (predicate integer?))) '(1 #f 3))) 'no)) - - (test-case - "mixed" - (define int-or-bool (signature (mixed integer boolean))) - (check-equal? (say-no (apply-signature int-or-bool #f)) - #f) - (check-equal? (say-no (apply-signature int-or-bool 17)) - 17) - (check-equal? (say-no (apply-signature int-or-bool "foo")) - 'no)) - - (test-case - "combined" - (define octet (signature (combined integer - (predicate (lambda (x) - (< x 256))) - (predicate (lambda (x) - (>= x 0)))))) - (check-equal? (say-no (apply-signature octet #f)) - 'no) - (check-equal? (say-no (apply-signature octet 17)) - 17) - (check-equal? (say-no (apply-signature octet 0)) - 0) - (check-equal? (say-no (apply-signature octet -1)) - 'no) - (check-equal? (say-no (apply-signature octet 255)) - 255) - (check-equal? (say-no (apply-signature octet 256)) - 'no) - (check-equal? (say-no (apply-signature octet "foo")) - 'no)) - - (test-case - "procedure" - (define int->bool (signature int->bool ((predicate integer?) -> (predicate boolean?)))) - (check-equal? (say-no (apply-signature int->bool #f)) - 'no) - (check-equal? (say-no (apply-signature int->bool (lambda () "foo"))) - 'no) - (check-equal? (say-no (apply-signature int->bool (lambda (x y) "foo"))) - 'no) - (let ((proc (say-no (apply-signature int->bool (lambda (x) (odd? x)))))) - (check-pred procedure? proc) - (check-equal? (proc 15) #t) - (check-equal? (proc 16) #f) - (check-equal? (say-no (proc "foo")) 'no)) - (let ((proc (say-no (apply-signature int->bool (lambda (x) (+ x 1)))))) - (check-equal? (say-no (proc 12)) 'no))) - - - (test-case - "record-wrap" - (define-record-procedures-parametric pare pare-of kons pare? (kar kdr)) - (define ctr (pare-of integer boolean)) - (let ((obj (apply-signature ctr (kons 1 #t)))) - (check-equal? (kar obj) 1) - (check-equal? (kdr obj) #t)) - (check-equal? (say-no (apply-signature ctr (kons 1 2))) 'no) - ) - - (test-case - "record-wrap/lazy" - (define-struct pare (kar kdr extra) - #:mutable - #:property prop:lazy-wrap - (make-lazy-wrap-info - (lambda (kar kdr) (kons kar kdr)) - (list (lambda (x) (pare-kar x)) (lambda (x) (pare-kdr x))) - (list (lambda (x v) (set-pare-kar! x v)) - (lambda (x v) (set-pare-kdr! x v))) - (lambda (x) (pare-extra x)) (lambda (x v) (set-pare-extra! x v)))) - (define (kons kar kdr) - (make-pare kar kdr #f)) - (define (kar p) - (check-lazy-wraps! struct:pare p) - (pare-kar p)) - (define (kdr p) - (check-lazy-wraps! struct:pare p) - (pare-kdr p)) - (define (pare-of kar-sig kdr-sig) - (make-lazy-wrap-signature 'pare #f - struct:pare - pare? - (list kar-sig kdr-sig) - #f)) - (define ctr (pare-of integer boolean)) - (let ((obj (apply-signature ctr (kons 1 #t)))) - (check-equal? (kar obj) 1) - (check-equal? (kdr obj) #t)) - (let ((obj (apply-signature ctr (kons 1 2)))) - (check-equal? (say-no (kar obj)) 'no)) - ) - - (test-case - "record-wrap-2" - (let ((count 0)) - (define counting-integer - (make-predicate-signature 'counting-integer - (lambda (obj) - (set! count (+ 1 count)) - (integer? obj)) - 'integer-marker)) - (define-record-procedures-parametric pare pare-of kons pare? (kar kdr)) - (define ctr (signature (pare-of counting-integer boolean))) - (let ((obj (apply-signature ctr (apply-signature ctr (kons 1 #t))))) - (check-equal? count 1) - (check-equal? (kar obj) 1) - (check-equal? count 1) - (check-equal? (kdr obj) #t) - (check-equal? count 1)))) - - (test-case - "record-wrap-2/lazy" - (let ((count 0)) - (define counting-integer - (make-predicate-signature 'counting-integer - (lambda (obj) - (set! count (+ 1 count)) - (integer? obj)) - 'integer-marker)) - - (define-struct pare (kar kdr extra) - #:mutable - #:property prop:lazy-wrap - (make-lazy-wrap-info - (lambda (kar kdr) (kons kar kdr)) - (list (lambda (x) (pare-kar x)) (lambda (x) (pare-kdr x))) - (list (lambda (x v) (set-pare-kar! x v)) - (lambda (x v) (set-pare-kdr! x v))) - (lambda (x) (pare-extra x)) (lambda (x v) (set-pare-extra! x v)))) - (define (kons kar kdr) - (make-pare kar kdr #f)) - (define (kar p) - (check-lazy-wraps! struct:pare p) - (pare-kar p)) - (define (kdr p) - (check-lazy-wraps! struct:pare p) - (pare-kdr p)) - (define (pare-of kar-sig kdr-sig) - (make-lazy-wrap-signature 'pare #f - struct:pare - pare? - (list kar-sig kdr-sig) - #f)) - - (define ctr (signature (pare-of counting-integer boolean))) - (let ((obj (apply-signature ctr (apply-signature ctr (kons 1 #t))))) - (check-equal? count 0) - (check-equal? (kar obj) 1) - (check-equal? count 1) - (check-equal? (kdr obj) #t) - (check-equal? count 1)))) - - (test-case - "record-wrap-3" - (let ((count 0)) - (define counting-integer - (make-predicate-signature 'counting-integer - (lambda (obj) - (set! count (+ 1 count)) - (integer? obj)) - 'integer-marker)) - - (define-record-procedures-parametric pare pare-of kons pare? (kar kdr)) - (define ctr (signature (pare-of counting-integer boolean))) - (let ((obj (apply-signature ctr (apply-signature ctr (kons 1 #t))))) - (check-equal? count 1) - (check-equal? (kar obj) 1) - (check-equal? count 1) - (check-equal? (kdr obj) #t) - (check-equal? count 1) - ;; after checking, the system should remember that it did so - (let ((obj-2 (apply-signature ctr obj))) - (check-equal? count 1) - (check-equal? (kar obj) 1) - (check-equal? count 1) - (check-equal? (kdr obj) #t) - (check-equal? count 1))))) - - (test-case - "record-wrap-3/lazy" - (let ((count 0)) - (define counting-integer - (make-predicate-signature 'counting-integer - (lambda (obj) - (set! count (+ 1 count)) - (integer? obj)) - 'integer-marker)) - (define-struct pare (kar kdr extra) - #:mutable - #:property prop:lazy-wrap - (make-lazy-wrap-info - (lambda (kar kdr) (kons kar kdr)) - (list (lambda (x) (pare-kar x)) (lambda (x) (pare-kdr x))) - (list (lambda (x v) (set-pare-kar! x v)) - (lambda (x v) (set-pare-kdr! x v))) - (lambda (x) (pare-extra x)) (lambda (x v) (set-pare-extra! x v)))) - (define (kons kar kdr) - (make-pare kar kdr #f)) - (define (kar p) - (check-lazy-wraps! struct:pare p) - (pare-kar p)) - (define (kdr p) - (check-lazy-wraps! struct:pare p) - (pare-kdr p)) - (define (pare-of kar-sig kdr-sig) - (make-lazy-wrap-signature 'pare #f - struct:pare - pare? - (list kar-sig kdr-sig) - #f)) - - (define ctr (signature (pare-of counting-integer boolean))) - (let ((obj (apply-signature ctr (apply-signature ctr (kons 1 #t))))) - (check-equal? count 0) - (check-equal? (kar obj) 1) - (check-equal? count 1) - (check-equal? (kdr obj) #t) - (check-equal? count 1) - ;; after checking, the system should remember that it did so - (let ((obj-2 (apply-signature ctr obj))) - (check-equal? count 1) - (check-equal? (kar obj) 1) - (check-equal? count 1) - (check-equal? (kdr obj) #t) - (check-equal? count 1))))) - - (test-case - "double-wrap" - (let ((count 0)) - (define counting-integer - (make-predicate-signature 'counting-integer - (lambda (obj) - (set! count (+ 1 count)) - (integer? obj)) - 'integer-marker)) - (define-record-procedures-parametric pare pare-of raw-kons pare? (kar kdr)) - - (define empty-list (signature (predicate null?))) - - (define my-list-of - (lambda (x) - (signature (mixed empty-list - (pare-of x (my-list-of x)))))) - - (define/signature kons (signature (%a (my-list-of %a) -> (pare-of %a (my-list-of %a)))) - raw-kons) - - (define/signature build-list (signature (integer -> (my-list-of counting-integer))) - (lambda (n) - (if (= n 0) - '() - (kons n (build-list (- n 1)))))) - - (define/signature list-length (signature ((my-list-of counting-integer) -> integer)) - (lambda (lis) - (cond - ((null? lis) 0) - ((pare? lis) - (+ 1 (list-length (kdr lis))))))) - - ;; one wrap each for (my-list-of %a), one for (my-list-of counting-integer) - (let ((l1 (build-list 10))) - (check-equal? count 10) - (let ((len1 (list-length l1))) - (check-equal? count 10))))) - - (test-case - "double-wrap/lazy" - (let ((count 0)) - (define counting-integer - (make-predicate-signature 'counting-integer - (lambda (obj) - (set! count (+ 1 count)) - (integer? obj)) - 'integer-marker)) - - (define-struct pare (kar kdr extra) - #:mutable - #:property prop:lazy-wrap - (make-lazy-wrap-info - (lambda (kar kdr) (raw-kons kar kdr)) - (list (lambda (x) (pare-kar x)) (lambda (x) (pare-kdr x))) - (list (lambda (x v) (set-pare-kar! x v)) - (lambda (x v) (set-pare-kdr! x v))) - (lambda (x) (pare-extra x)) (lambda (x v) (set-pare-extra! x v)))) - (define (raw-kons kar kdr) - (make-pare kar kdr #f)) - (define (kar p) - (check-lazy-wraps! struct:pare p) - (pare-kar p)) - (define (kdr p) - (check-lazy-wraps! struct:pare p) - (pare-kdr p)) - (define (pare-of kar-sig kdr-sig) - (make-lazy-wrap-signature 'pare #f - struct:pare - pare? - (list kar-sig kdr-sig) - #f)) - - - (define empty-list (signature (predicate null?))) - - (define my-list-of - (lambda (x) - (signature (mixed empty-list - (pare-of x (my-list-of x)))))) - - (define/signature kons (signature (%a (my-list-of %a) -> (pare-of %a (my-list-of %a)))) - raw-kons) - - (define/signature build-list (signature (integer -> (my-list-of counting-integer))) - (lambda (n) - (if (= n 0) - '() - (kons n (build-list (- n 1)))))) - - (define/signature list-length (signature ((my-list-of counting-integer) -> integer)) - (lambda (lis) - (cond - ((null? lis) 0) - ((pare? lis) - (+ 1 (list-length (kdr lis))))))) - - ;; one wrap each for (my-list-of %a), one for (my-list-of counting-integer) - (let ((l1 (build-list 10))) - (check-equal? count 0) - (let ((len1 (list-length l1))) - (check-equal? count 10))))) - - (test-case - "mixed wrap" - - (define-struct pare (kar kdr extra) - #:mutable - #:property prop:lazy-wrap - (make-lazy-wrap-info - (lambda (kar kdr) (raw-kons kar kdr)) - (list (lambda (x) (pare-kar x)) (lambda (x) (pare-kdr x))) - (list (lambda (x v) (set-pare-kar! x v)) - (lambda (x v) (set-pare-kdr! x v))) - (lambda (x) (pare-extra x)) (lambda (x v) (set-pare-extra! x v)))) - (define (raw-kons kar kdr) - (make-pare kar kdr #f)) - (define (kar p) - (check-lazy-wraps! struct:pare p) - (pare-kar p)) - (define (kdr p) - (check-lazy-wraps! struct:pare p) - (pare-kdr p)) - (define (pare-of kar-sig kdr-sig) - (make-lazy-wrap-signature 'pare #f - struct:pare - pare? - (list kar-sig kdr-sig) - #f)) - - - (define sig1 (signature (pare-of integer boolean))) - (define sig2 (signature (pare-of boolean integer))) - (define sig (signature (mixed sig1 sig2))) - (define/signature x sig (raw-kons #t 15)) - (define/signature y sig (raw-kons #t #t)) - (check-equal? (kar x) #t) - (check-equal? (say-no (kar y)) 'no)) - - (test-case - "wrap equality" - (define-record-procedures-parametric pare pare-of raw-kons pare? (kar kdr)) - - (define empty-list (signature (predicate null?))) - - (define my-list-of - (lambda (x) - (signature (mixed empty-list - (pare-of x (my-list-of x)))))) - - (define/signature kons (signature (%a (my-list-of %a) -> (pare-of %a (my-list-of %a)))) - raw-kons) - - (check-equal? (raw-kons 1 '()) (raw-kons 1 '())) - (check-equal? (kons 1 '()) (kons 1 '())) - (check-equal? (kons 1 '()) (raw-kons 1 '())) - (check-equal? (raw-kons 1 '()) (kons 1 '()))) - - (test-case - "pair-wrap" - (define sig (make-pair-signature #f integer boolean)) - (let ((obj (apply-signature sig (cons 1 #t)))) - (check-equal? (checked-car obj) 1) - (check-equal? (checked-cdr obj) #t)) - (let ((obj (apply-signature sig (cons 1 2)))) - (check-equal? (say-no (checked-car obj)) 'no)) - ) - -)) - - -(define all-signature-tests - (test-suite - "all-signature-tests" - signature-tests - signature-syntax-tests)) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/tests/test-docs-complete.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/tests/test-docs-complete.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/tests/test-docs-complete.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/tests/test-docs-complete.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,10 +0,0 @@ -#lang racket/base -(require rackunit/docs-complete) - -(check-docs (quote deinprogramm/world)) -(check-docs (quote deinprogramm/image)) - -(check-docs (quote deinprogramm/DMdA-beginner) #:skip #rx"(^#%)|(^\\.\\.)|(^contract$)|(^define-contract$)|(^match$)") -(check-docs (quote deinprogramm/DMdA-vanilla) #:skip #rx"(^#%)|(^\\.\\.)|(^contract$)|(^define-contract$)|(^match$)") -(check-docs (quote deinprogramm/DMdA-advanced) #:skip #rx"(^#%)|(^\\.\\.)|(^contract$)|(^define-contract$)|(^match$)") -(check-docs (quote deinprogramm/DMdA-assignments) #:skip #rx"(^#%)|(^\\.\\.)|(^contract$)|(^define-contract$)|(^match$)") diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/turtle.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/turtle.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/turtle.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/turtle.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,219 +0,0 @@ -#lang scheme - -(require mzlib/math - (only-in deinprogramm/image rectangle line overlay image-color? image image-color) - (only-in lang/private/imageeq image?) - deinprogramm/signature/signature-syntax) - -(provide set-color - turn - draw - move - run - sequence - turtle - image - image-color) - - ; used to convert angles - (define pi/180 (/ pi 180)) - - ; convert angle value - ; (: grad->rad (number -> number)) - (define grad->rad - (lambda (grad) - (* pi/180 grad))) - - (define turtle (signature - (predicate (lambda (x) - (and (vector? x) - (= (vector-length x) 8) - (number? (vector-ref x 0)) - (number? (vector-ref x 1)) - (number? (vector-ref x 2)) - (number? (vector-ref x 3)) - (number? (vector-ref x 4)) - (image? (vector-ref x 5)) - (image-color? (vector-ref x 6))))))) - - ; This function is only for internal use. - ; (new-turtle-priv h w x y angle img color state) - ; creates a new turtle with hight h, width w. - ; The cursor is at position (x,y) and the view direction - ; is defined by an angle value relative to the vector (1,0) . - ; The two next componets represents the image and the - ; color of the pen. The last component represents an abritary - ; value, that allows to transport state with the turtle. - (: new-turtle-priv (number number number number number image image-color %A -> turtle)) - (define new-turtle-priv - (lambda (h w x y angle img color state) - (vector h w x y angle img color state))) - - - ; (new-turtle h w color) - ; creates a new turtle with the pen color color and sets the - ; width of the image to w and the hight to h. - ; The background of the image is gray and the position of the - ; cursor is (0,0) and the view direction is (1,0). - (: new-turtle (number number image-color -> turtle)) - (define new-turtle - (lambda (h w color) - (let ((x (floor (/ w 2))) - (y (floor (/ h 2)))) - (new-turtle-priv h w x y 0 (rectangle w h "solid" "gray") color #f)))) - - ; (new-turtle-complex h w color bgcolor x y angle) - ; creates a new turtle with the pen color color and sets the - ; width of the image to w and the hight to h. - ; The background of the image is bgcolor and the position of the - ; cursor is (x,y) and the view direction is (1,0) * e^(- i angle). - (: new-turtle (number number image-color image-color number number number -> turtle)) - (define new-turtle-complex - (lambda (h w color bgcolor x y angle) - (new-turtle-priv h w x y angle (rectangle w h "solid" bgcolor) color #f))) - - - ; For internal use only - (: get-h (turtle -> number)) - (define get-h (lambda (t) (vector-ref t 0))) - (: get-w (turtle -> number)) - (define get-w (lambda (t) (vector-ref t 1))) - (: get-x (turtle -> number)) - (define get-x (lambda (t) (vector-ref t 2))) - (: get-y (turtle -> number)) - (define get-y (lambda (t) (vector-ref t 3))) - (: get-angle (turtle -> number)) - (define get-angle (lambda (t) (vector-ref t 4))) - (: get-iamge (turtle -> image)) - (define get-image (lambda (t) (vector-ref t 5))) - (: get-color (turtle -> image-color)) - (define get-color (lambda (t) (vector-ref t 6))) - (: get-state (turtle -> %A)) - (define get-state (lambda (t) (vector-ref t 7))) - - ; (set-color color) - ; returns a function of type turtle -> turtle. - ; Use the result to change the color of the pen. - (: set-color (image-color -> (turtle -> turtle))) - (define set-color - (lambda (color) - (lambda (t) - (let* ((h (get-h t)) - (w (get-w t)) - (x (get-x t)) - (y (get-y t)) - (angle (get-angle t)) - (image (get-image t))) - (new-turtle-priv h w x y angle image color #f))))) - - ; (turn angle) - ; returns a function of type turtle -> turtle. - ; Use the result to turn the view of the turtle (counter-clockwise). - (: turn (number -> (turtle -> turtle))) - (define turn - (lambda (grad) - (lambda (t) - (let* ((h (get-h t)) - (w (get-w t)) - (x (get-x t)) - (y (get-y t)) - (angle (get-angle t)) - (image (get-image t)) - (color (get-color t)) - (state (get-state t))) - (new-turtle-priv h w x y (- angle grad) image color state))))) - - ; For internal use only - ; (move-cursor turtle length) - ; returns a new turtle where the cursor - ; is moved length steps along the view vector. - (: move-cursor (turtle number -> turtle)) - (define move-cursor - (lambda (t length) - (let* ((h (get-h t)) - (w (get-w t)) - (x (get-x t)) - (y (get-y t)) - (angle (get-angle t)) - (image (get-image t)) - (color (get-color t)) - (state (get-state t)) - (newx (+ x (* length (cos (grad->rad angle))))) - (newy (+ y (* length (sin (grad->rad angle)))))) - (new-turtle-priv h w newx newy angle image color state)))) - - ; (draw length) - ; returns a function of type turtle -> turtle. - ; The result can be used to move the turtle and draw a line. - (: draw (number -> (turtle -> turtle))) - (define draw - (lambda (length) - (lambda (t) - (let* ((h (get-h t)) - (w (get-w t)) - (x (get-x t)) - (y (get-y t)) - (angle (get-angle t)) - (image (get-image t)) - (color (get-color t)) - (state (get-state t)) - ; Compute new coordinats - (newx (+ x (* length (cos (grad->rad angle))))) - (newy (+ y (* length (sin (grad->rad angle)))))) - (new-turtle-priv - h w - newx newy angle - ; Compute new image - (overlay image - (line w h x y newx newy color) 0 0) - color state))))) - - ; (move length) - ; returns a function of type turtle -> turtle. - ; The result can be used to move the turtle without drawing a line. - (: move (number -> (turtle -> turtle))) - (define move - (lambda (length) - (lambda (t) - (move-cursor t length)))) - - ; runs a turtle function - (: run ((turtle -> turtle) number number image-color -> image)) - (define run - (lambda (t->t h w color) - (get-image (t->t (new-turtle h w color))))) - -; ; runs a turtle function -; ; (: run* ((turtle -> turtle) -> turtle -> image)) -; (define run* -; (lambda (t->t h w color bgcolor x y angle) -; (get-image (t->t (new-turtle h w color bgcolor x y angle))))) - - ; This function is only for internal use. - (define comp_priv_2 - (lambda (f1 f2) - (lambda (t) - (f2 (f1 t))))) - - ; This function is only for internal use. - (define comp_priv - (lambda (l) - (cond - ((null? l) (error "sequence erwartet mind. ein Argument")) - ((list? l) - (let ((head (car l)) - (tail (cdr l))) - (if (null? tail) - head - (comp_priv_2 head (comp_priv tail)))))))) - - ; This function allows to do a list of - ; turtle -> turtle - ; functions into one new function, that do - ; one action of the turtle, then later the rest. - ; Define the type alias tip = turtle -> turtle. - (define tip (signature (turtle -> turtle))) - (: do (tip ... -> tip)) - (define sequence (lambda l (comp_priv l))) - - diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/world.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/world.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/deinprogramm/world.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/deinprogramm/world.rkt 1970-01-01 00:00:00.000000000 +0000 @@ -1,270 +0,0 @@ -#lang scheme/base - -;; Mon Mar 27 10:29:28 EST 2006: integrated Felix's mouse events -;; Wed Jan 25 13:38:42 EST 2006: on-redraw: proc is now called on installation -;; Tue Jan 3 11:17:50 EST 2006: changed add-line behavior in world.rkt -;; Sat Dec 10 19:39:03 EST 2005: fixed name, changed interface to on-key-event -;; Fri Dec 9 21:39:03 EST 2005: remoevd (update ... produce ...); added on-redraw -;; Thu Dec 1 17:03:03 EST 2005: fixed place-image; all coordinates okay now - - (require - (except-in mred make-color) - mzlib/class - htdp/error - "image.rkt" - (prefix-in beg: lang/htdp-beginner) - lang/prim - deinprogramm/signature/signature-syntax) - - ;; --- provide --------------------------------------------------------------- - (provide (all-from-out "image.rkt")) - - (provide ;; forall(World): - big-bang ;; Number Number Number World -> true - end-of-time ;; String u Symbol -> World - ) - - (provide-higher-order-primitive - on-tick-event (tock) ;; (World -> World) -> true - ) - - (provide-higher-order-primitive - on-redraw (world-image) ;; (World -> Image) -> true - ) - - ;; KeyEvent is one of: - ;; -- Char - ;; -- Symbol - - (provide-higher-order-primitive ;; (World KeyEvent -> World) -> true - on-key-event - (draw) - ) - - ;; A MouseEventKind is one of: - ;; "enter" -- mouse pointer entered the window - ;; "leave" -- mouse pointer left the window - ;; "left-down" -- left mouse button pressed - ;; "left-up" -- left mouse button released - ;; "middle-down" -- middle mouse button pressed - ;; "middle-up" -- middle mouse button released - ;; "right-down" -- right mouse button pressed (Mac OS: click with control key pressed) - ;; "right-up" -- right mouse button released (Mac OS: release with control key pressed) - ;; "motion" -- mouse moved, with or without button(s) pressed - - - (provide-higher-order-primitive ;; (World Number Number MouseEventKind -> World) -> true - on-mouse-event - (clack) - ) - - (provide mouse-event-kind) - - (define mouse-event-kind - (signature - (one-of "enter" "leave" "motion" "left-down" "left-up" "middle-down" "middle-up" "right-down" "right-up"))) - - ;; --------------------------------------------------------------------------- - - ;; Symbol Any String -> Void - (define (check-pos tag c rank) - (check-arg tag (and (number? c) (integer? c) (>= c 0)) "positive integer" rank c)) - - ;; --------------------------------------------------------------------------- - - ;; The One and Only Visible World - (define the-frame #f) - (define txt (new text%)) - - ;; World (type parameter) - (define the-world0 (cons 1 1)) - [define the-world the-world0] - - (define (check-world tag) - (when (eq? the-world0 the-world) (error tag SEQUENCE-ERROR))) - - ;; Number > 0 - [define the-delta 1000] - - ;; Amount of space around the image in the world window: - (define INSET 5) - - ;; Number Number Number World -> true - ;; create the visible world (canvas) - (define (big-bang w h delta world) - (check-pos 'big-bang w "first") - (check-pos 'big-bang h "second") - (check-arg 'big-bang - (and (number? delta) (<= 0 delta 1000)) - "number [of seconds] between 0 and 1000" - "first" - delta) - (when the-frame (error 'big-bang "big-bang already called once")) - (set! the-delta delta) - (set! the-world world) - (set! the-frame - (new (class frame% - (super-new) - (define/augment (on-close) - ;; shut down the timer when the window is destroyed - (send the-time stop) - (inner (void) on-close))) - (label "DrRacket") - (stretchable-width #f) - (stretchable-height #f) - (style '(no-resize-border metal)))) - (let ([c (new (class editor-canvas% - (super-new) - (define/override (on-char e) - (on-char-proc (send e get-key-code))) - (define/override (on-event e) - (on-mouse-proc e))) - (parent the-frame) - (editor txt) - (style '(no-hscroll no-vscroll)) - (horizontal-inset INSET) - (vertical-inset INSET))]) - (send c min-client-width (+ w INSET INSET)) - (send c min-client-height (+ h INSET INSET)) - (send c focus)) - (send txt set-cursor (make-object cursor% 'arrow)) - (send txt hide-caret #t) - (send the-frame show #t) - #t) - - ;; --- time events - [define the-time (new timer% [notify-callback (lambda () (timer-callback))])] - - ;; (World -> World) - [define timer-callback void] - - [define (on-tick-event f) - (check-proc 'on-tick-event f 1 "on-tick-event" "one argument") - (check-world 'on-tick-event) - (if (eq? timer-callback void) - (set! timer-callback - (lambda () - (with-handlers ([exn:break? break-handler] - [exn? exn-handler]) - (set! the-world (f the-world)) - (on-redraw-proc)))) - (error 'on-tick "the timing action has been set already")) - (send the-time start - (let* ([w (ceiling (* 1000 the-delta))]) - (if (exact? w) w (inexact->exact w)))) - #t] - - ;; --- key and mouse events - - ;; KeyEvent -> Void - [define on-char-proc void] - - [define (on-key-event f) - (check-proc 'on-key-event f 2 "on-key-event" "two arguments") - (check-world 'on-key-event) - (let ([esp (current-eventspace)]) - (if (eq? on-char-proc void) - (begin - (set! on-char-proc - (lambda (e) - (cond - ((event->string e) - => (lambda (s) - (parameterize ([current-eventspace esp]) - (queue-callback - (lambda () - (with-handlers ([exn:break? break-handler] - [exn? exn-handler]) - (set! the-world (f the-world s)) - (on-redraw-proc)))))))) - #t)) - #t) - (error 'on-event "the event action has been set already")))] - - (define (event->string e) - (if (char? e) - (string e) - (case e - ((left) "left") - ((right) "right") - ((up) "up") - ((down) "down") - ((wheel-up) "wheel-up") - ((wheel-down) "wheel-down") - (else #f)))) - - [define (end-of-time s) - (printf "end of time: ~a\n" s) - (stop-it) - the-world] - - ;; MouseEvent -> Void - [define on-mouse-proc void] - - [define (on-mouse-event f) - (check-proc 'on-mouse-event f 4 "on-mouse-event" "four arguments") - (check-world 'on-mouse-event) - (let ([esp (current-eventspace)]) - (if (eq? on-mouse-proc void) - (begin - (set! on-mouse-proc - (lambda (e) - (parameterize ([current-eventspace esp]) - (queue-callback - (lambda () - (with-handlers ([exn:break? break-handler] - [exn? exn-handler]) - (set! the-world (f the-world - (send e get-x) - (send e get-y) - (symbol->string (send e get-event-type)))) - (on-redraw-proc)))) - #t))) - #t) - (error 'on-mouse-event "the mouse event action has been set already")))] - - ;; --- library - [define (exn-handler e) - (send the-time stop) - (set! on-char-proc void) - (set! timer-callback void) - (raise e)] - - [define (break-handler . _) - (printf "animation stopped") - (stop-it) - the-world] - - ;; -> Void - (define (stop-it) - (send the-time stop) - (set! on-char-proc void) - (set! timer-callback void)) - - (define on-redraw-proc void) - - (define (on-redraw f) - (check-proc 'on-redraw f 1 "on-redraw" "one argument") - (check-world 'on-redraw) - (if (eq? on-redraw-proc void) - (begin - (set! on-redraw-proc - (lambda () - (with-handlers ([exn:break? break-handler] - [exn? exn-handler]) - (define img (f the-world)) - (check-result 'on-redraw (lambda (x) (beg:image? x)) "image" img) - (update-frame img) - #t))) - (on-redraw-proc)) - (error 'on-redraw "the redraw function has already been specified"))) - - (define (update-frame pict) - (send txt begin-edit-sequence) - (send txt lock #f) - (send txt delete 0 (send txt last-position) #f) - (send txt insert (send pict copy) 0 0 #f) - (send txt lock #t) - (send txt end-edit-sequence)) - - (define SEQUENCE-ERROR "evaluate (big-bang Number Number Number World) first") diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/info.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/info.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/deinprogramm/teachpack/deinprogramm/image.ss racket-7.3+ppa1/share/pkgs/deinprogramm/teachpack/deinprogramm/image.ss --- racket-7.2+ppa2/share/pkgs/deinprogramm/teachpack/deinprogramm/image.ss 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/teachpack/deinprogramm/image.ss 2019-05-16 01:29:07.000000000 +0000 @@ -1,3 +1,3 @@ (module image mzscheme - (require (lib "image.ss" "deinprogramm")) - (provide (all-from (lib "image.ss" "deinprogramm")))) + (require (lib "image.ss" "deinprogramm" "DMdA" "teachpack")) + (provide (all-from (lib "image.ss" "deinprogramm" "DMdA" "teachpack")))) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/teachpack/deinprogramm/line3d.ss racket-7.3+ppa1/share/pkgs/deinprogramm/teachpack/deinprogramm/line3d.ss --- racket-7.2+ppa2/share/pkgs/deinprogramm/teachpack/deinprogramm/line3d.ss 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/teachpack/deinprogramm/line3d.ss 2019-05-16 01:29:07.000000000 +0000 @@ -1,3 +1,3 @@ (module line3d mzscheme - (provide (all-from (lib "line3d.ss" "deinprogramm"))) - (require (lib "line3d.ss" "deinprogramm"))) + (provide (all-from (lib "line3d.ss" "deinprogramm" "DMdA" "teachpack"))) + (require (lib "line3d.ss" "deinprogramm" "DMdA" "teachpack"))) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/teachpack/deinprogramm/sdp/image.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/teachpack/deinprogramm/sdp/image.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/teachpack/deinprogramm/sdp/image.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/teachpack/deinprogramm/sdp/image.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,31 @@ +#lang racket/base +(provide (all-from-out teachpack/2htdp/image) + image mode image-color color y-place x-place + pulled-point angle side-count step-count + real-valued-posn + pen pen-style pen-cap pen-join) + +(require teachpack/2htdp/image) +(require deinprogramm/signature/signature) +(require deinprogramm/signature/signature-syntax) +(require deinprogramm/signature/signature-german) + +(define image (signature image (predicate image?))) +(define mode (signature mode (predicate mode?))) +(define image-color (signature image-color (predicate image-color?))) +(define color (signature color (predicate color?))) +(define y-place (signature y-place (predicate y-place?))) +(define x-place (signature x-place (predicate x-place?))) +(define pulled-point (signature pulled-point (predicate pulled-point?))) +(define angle (signature angle (predicate angle?))) +(define side-count (signature side-count (predicate side-count?))) +(define step-count (signature step-count (predicate step-count?))) +(define real-valued-posn (signature real-valued-posn (predicate real-valued-posn?))) +(define pen (signature pen (predicate pen?))) +(define pen-style (signature pen-style (predicate pen-style?))) +(define pen-cap (signature pen-cap (predicate pen-cap?))) +(define pen-join (signature pen-joint (predicate pen-join?))) + + + + diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/teachpack/deinprogramm/sdp/info.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/teachpack/deinprogramm/sdp/info.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/teachpack/deinprogramm/sdp/info.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/teachpack/deinprogramm/sdp/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,3 @@ +#lang info + +(define deinprogramm-sdp-teachpacks 'all) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/teachpack/deinprogramm/sdp/universe.rkt racket-7.3+ppa1/share/pkgs/deinprogramm/teachpack/deinprogramm/sdp/universe.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm/teachpack/deinprogramm/sdp/universe.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/teachpack/deinprogramm/sdp/universe.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,3 @@ +(module universe mzscheme + (provide (all-from 2htdp/universe)) + (require 2htdp/universe)) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/teachpack/deinprogramm/turtle.ss racket-7.3+ppa1/share/pkgs/deinprogramm/teachpack/deinprogramm/turtle.ss --- racket-7.2+ppa2/share/pkgs/deinprogramm/teachpack/deinprogramm/turtle.ss 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/teachpack/deinprogramm/turtle.ss 2019-05-16 01:29:07.000000000 +0000 @@ -1,3 +1,3 @@ (module turtle mzscheme - (provide (all-from (lib "turtle.ss" "deinprogramm"))) - (require (lib "turtle.ss" "deinprogramm"))) + (provide (all-from (lib "turtle.ss" "deinprogramm" "DMdA" "teachpack"))) + (require (lib "turtle.ss" "deinprogramm" "DMdA" "teachpack"))) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm/teachpack/deinprogramm/world.ss racket-7.3+ppa1/share/pkgs/deinprogramm/teachpack/deinprogramm/world.ss --- racket-7.2+ppa2/share/pkgs/deinprogramm/teachpack/deinprogramm/world.ss 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm/teachpack/deinprogramm/world.ss 2019-05-16 01:29:07.000000000 +0000 @@ -1,3 +1,4 @@ (module world mzscheme - (provide (all-from (lib "world.ss" "deinprogramm"))) - (require (lib "world.ss" "deinprogramm"))) + (provide (all-from (lib "world.ss" "deinprogramm" "DMdA" "teachpack"))) + (require (lib "world.ss" "deinprogramm" "DMdA" "teachpack"))) + diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm-signature/deinprogramm/quickcheck/quickcheck.rkt racket-7.3+ppa1/share/pkgs/deinprogramm-signature/deinprogramm/quickcheck/quickcheck.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm-signature/deinprogramm/quickcheck/quickcheck.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm-signature/deinprogramm/quickcheck/quickcheck.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -11,7 +11,7 @@ arbitrary-integer arbitrary-natural arbitrary-rational arbitrary-real arbitrary-mixed arbitrary-one-of arbitrary-pair - arbitrary-list + arbitrary-list arbitrary-nonempty-list arbitrary-vector arbitrary-tuple arbitrary-record arbitrary-string diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm-signature/deinprogramm/quickcheck/quickcheck.scm racket-7.3+ppa1/share/pkgs/deinprogramm-signature/deinprogramm/quickcheck/quickcheck.scm --- racket-7.2+ppa2/share/pkgs/deinprogramm-signature/deinprogramm/quickcheck/quickcheck.scm 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm-signature/deinprogramm/quickcheck/quickcheck.scm 2019-05-16 01:29:07.000000000 +0000 @@ -338,10 +338,10 @@ (recur (cdr arbitrary-els) (cdr lis)))))))) -(define (arbitrary-sequence choose-sequence sequence->list arbitrary-el) +(define (arbitrary-sequence min-length choose-sequence sequence->list arbitrary-el) (make-arbitrary (sized (lambda (n) - (>>= (choose-integer 0 n) + (>>= (choose-integer min-length (+ n min-length)) (lambda (length) (choose-sequence (arbitrary-generator arbitrary-el) length))))) (lambda (seq gen) @@ -353,22 +353,25 @@ (variant 1 (recur (cdr lis))))))))) (define (arbitrary-list arbitrary-el) - (arbitrary-sequence choose-list values arbitrary-el)) + (arbitrary-sequence 0 choose-list values arbitrary-el)) + +(define (arbitrary-nonempty-list arbitrary-el) + (arbitrary-sequence 1 choose-list values arbitrary-el)) (define (arbitrary-vector arbitrary-el) - (arbitrary-sequence choose-vector vector->list arbitrary-el)) + (arbitrary-sequence 0 choose-vector vector->list arbitrary-el)) (define arbitrary-ascii-string - (arbitrary-sequence choose-string string->list arbitrary-ascii-char)) + (arbitrary-sequence 0 choose-string string->list arbitrary-ascii-char)) (define arbitrary-printable-ascii-string - (arbitrary-sequence choose-string string->list arbitrary-printable-ascii-char)) + (arbitrary-sequence 0 choose-string string->list arbitrary-printable-ascii-char)) (define arbitrary-string - (arbitrary-sequence choose-string string->list arbitrary-char)) + (arbitrary-sequence 0 choose-string string->list arbitrary-char)) (define arbitrary-symbol - (arbitrary-sequence choose-symbol + (arbitrary-sequence 0 choose-symbol (lambda (symbol) (string->list (symbol->string symbol))) arbitrary-ascii-letter)) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm-signature/deinprogramm/signature/signature-syntax.rkt racket-7.3+ppa1/share/pkgs/deinprogramm-signature/deinprogramm/signature/signature-syntax.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm-signature/deinprogramm/signature/signature-syntax.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm-signature/deinprogramm/signature/signature-syntax.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -4,7 +4,7 @@ signature signature/arbitrary define-contract contract ; legacy define/signature define-values/signature - -> mixed one-of predicate combined property list-of) + -> mixed one-of predicate combined property list-of nonempty-list-of) (require deinprogramm/signature/signature deinprogramm/signature/signature-german @@ -20,7 +20,7 @@ (define-for-syntax (parse-signature name stx) (syntax-case* stx - (mixed one-of predicate list -> combined property reference at signature list-of) + (mixed one-of predicate list -> combined property reference at signature list-of nonempty-list-of) module-or-top-identifier=? ((mixed ?signature ...) (with-syntax ((?stx (phase-lift stx)) @@ -72,6 +72,15 @@ (raise-syntax-error #f "list-of-Signatur darf nur einen Operanden haben." (syntax ?signature1))) + ((nonempty-list-of ?signature) + (with-syntax ((?stx (phase-lift stx)) + (?name name) + (?signature-expr (parse-signature #f #'?signature))) + #'(make-nonempty-list-signature '?name ?signature-expr ?stx))) + ((nonempty-list-of ?signature) + (raise-syntax-error #f + "nonempty-list-of-Signatur darf nur einen Operanden haben." + (syntax ?signature1))) ((?arg-signature ... -> ?return-signature) (with-syntax ((?stx (phase-lift stx)) (?name name) @@ -290,3 +299,4 @@ (define-syntax combined within-signature-syntax-transformer) (define-syntax property within-signature-syntax-transformer) (define-syntax list-of within-signature-syntax-transformer) +(define-syntax nonempty-list-of within-signature-syntax-transformer) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm-signature/deinprogramm/signature/signature-unit.rkt racket-7.3+ppa1/share/pkgs/deinprogramm-signature/deinprogramm/signature/signature-unit.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm-signature/deinprogramm/signature/signature-unit.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm-signature/deinprogramm/signature/signature-unit.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -25,6 +25,7 @@ make-predicate-signature make-type-variable-signature make-list-signature + make-nonempty-list-signature make-vector-signature make-mixed-signature make-combined-signature @@ -131,34 +132,37 @@ ; maps lists to pairs of signature, enforced value (define lists-table (make-weak-hasheq)) +(define (check-list arg-signature self obj) + + (let recur ((l obj)) + (define (go-on) + (let ((enforced (cons (apply-signature arg-signature (car l)) + (recur (cdr l))))) + (hash-set! lists-table l (cons self enforced)) + (hash-set! lists-table enforced (cons self enforced)) + enforced)) + + (cond + ((null? l) + l) + ((not (pair? l)) + (signature-violation obj self #f #f) + obj) + ((hash-ref lists-table l #f) + => (lambda (seen) + ;;(eprintf "~s\n" (list 'seen seen (eq? self (car seen)))) + (if (eq? self (car seen)) + (cdr seen) + (go-on)))) + (else + (go-on))))) + (define (make-list-signature name arg-signature syntax) (make-signature name (lambda (self obj) ;;(eprintf "~s\n" (list 'list obj)) - (let recur ((l obj)) - - (define (go-on) - (let ((enforced (cons (apply-signature arg-signature (car l)) - (recur (cdr l))))) - (hash-set! lists-table l (cons self enforced)) - (hash-set! lists-table enforced (cons self enforced)) - enforced)) - - (cond - ((null? l) - l) - ((not (pair? l)) - (signature-violation obj self #f #f) - obj) - ((hash-ref lists-table l #f) - => (lambda (seen) - ;;(eprintf "~s\n" (list 'seen seen (eq? self (car seen)))) - (if (eq? self (car seen)) - (cdr seen) - (go-on)))) - (else - (go-on))))) + (check-list arg-signature self obj)) (delay syntax) #:arbitrary-promise (delay @@ -172,6 +176,30 @@ (define-struct list-info (arg-signature) #:transparent) +(define (make-nonempty-list-signature name arg-signature syntax) + (make-signature + name + (lambda (self obj) + ;;(eprintf "~s\n" (list 'list obj)) + (if (null? obj) + (begin + (signature-violation obj self #f #f) + obj) + (check-list arg-signature self obj))) + (delay syntax) + #:arbitrary-promise + (delay + (lift->arbitrary arbitrary-nonempty-list arg-signature)) + #:info-promise + (delay (make-nonempty-list-info arg-signature)) + #:=?-proc + (lambda (this-info other-info) + (and (nonempty-list-info? other-info) + (signature=? arg-signature (nonempty-list-info-arg-signature other-info)))))) + +(define-struct nonempty-list-info (arg-signature) #:transparent) + + (define (lift->arbitrary proc . signatures) (let ((arbitraries (map force (map signature-arbitrary-promise signatures)))) (if (andmap values arbitraries) diff -Nru racket-7.2+ppa2/share/pkgs/deinprogramm-signature/info.rkt racket-7.3+ppa1/share/pkgs/deinprogramm-signature/info.rkt --- racket-7.2+ppa2/share/pkgs/deinprogramm-signature/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/deinprogramm-signature/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/distributed-places/info.rkt racket-7.3+ppa1/share/pkgs/distributed-places/info.rkt --- racket-7.2+ppa2/share/pkgs/distributed-places/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/distributed-places/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/distributed-places-doc/info.rkt racket-7.3+ppa1/share/pkgs/distributed-places-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/distributed-places-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/distributed-places-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/distributed-places-lib/info.rkt racket-7.3+ppa1/share/pkgs/distributed-places-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/distributed-places-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/distributed-places-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/draw/info.rkt racket-7.3+ppa1/share/pkgs/draw/info.rkt --- racket-7.2+ppa2/share/pkgs/draw/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/draw/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/draw-doc/info.rkt racket-7.3+ppa1/share/pkgs/draw-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/draw-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/draw-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/draw-lib/info.rkt racket-7.3+ppa1/share/pkgs/draw-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/draw-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/draw-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.14"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.3"))) (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.15"))) diff -Nru racket-7.2+ppa2/share/pkgs/draw-lib/racket/draw/private/font.rkt racket-7.3+ppa1/share/pkgs/draw-lib/racket/draw/private/font.rkt --- racket-7.2+ppa2/share/pkgs/draw-lib/racket/draw/private/font.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/draw-lib/racket/draw/private/font.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -348,10 +348,27 @@ (if (not all-variants?) (list (pango_font_family_get_name fam)) (for/list ([face (in-list (pango_font_family_list_faces fam))]) - (string-append - (pango_font_family_get_name fam) - ", " - (pango_font_face_get_face_name face)))))) + (define family-name (pango_font_family_get_name fam)) + (define full-name (pango_font_description_to_string + (pango_font_face_describe face))) + (define len (string-length family-name)) + ;; Normally, the full description will extend the family name: + (cond + [(and ((string-length full-name) . > . (+ len 1)) + (string=? (substring full-name 0 len) family-name) + (char=? #\space (string-ref full-name len))) + (string-append family-name "," (substring full-name len))] + [#f + ;; If the full description doesn't extend the name, then we + ;; could show more information by adding the font's declared + ;; face string. But that may not be parseable by Pango, so + ;; we don't return this currently. Maybe one day add an option + ;; to expose this string. + (string-append family-name ", " (pango_font_face_get_face_name face))] + [else + ;; In this case, we can't say more than just the family name, + ;; even though that may produce duplicates (but usually won't) + family-name]))))) string _void)) (define-pango pango_font_description_get_family (_pfun PangoFontDescription -> _string)) +(define-pango pango_font_description_to_string/ptr (_pfun PangoFontDescription -> _pointer) + #:c-id pango_font_description_to_string + #:wrap (allocator g_free)) +(define (pango_font_description_to_string desc) + (cast (pango_font_description_to_string/ptr desc) _pointer _string)) +(provide pango_font_description_to_string) + +(define-pango pango_font_face_describe (_pfun PangoFontFace -> PangoFontDescription) + #:wrap (allocator pango_font_description_free)) + (define _PangoWin32FontCache (_cpointer 'PangoWin32FontCache)) (define _HFONT (_cpointer 'HFONT)) (define _LOGFONT-pointer _pointer) diff -Nru racket-7.2+ppa2/share/pkgs/drracket/drracket/HISTORY.txt racket-7.3+ppa1/share/pkgs/drracket/drracket/HISTORY.txt --- racket-7.2+ppa2/share/pkgs/drracket/drracket/HISTORY.txt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/drracket/drracket/HISTORY.txt 2019-05-16 01:29:07.000000000 +0000 @@ -1,5 +1,14 @@ ------------------------------ - Version 7.1 + Version 7.3 +------------------------------ + + . Improved DrRacket's support for the OS's + light-on-dark color schemes + + . minor bug fixes + +------------------------------ + Version 7.2 ------------------------------ . Added QuickScript to the standard install for DrRacket. diff -Nru racket-7.2+ppa2/share/pkgs/drracket/drracket/private/frame.rkt racket-7.3+ppa1/share/pkgs/drracket/drracket/private/frame.rkt --- racket-7.2+ppa2/share/pkgs/drracket/drracket/private/frame.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/drracket/drracket/private/frame.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -195,6 +195,7 @@ framework/private/srcloc-panel net/url net/head + browser/external setup/plt-installer help/bug-report setup/unpack @@ -869,6 +870,23 @@ (define (drracket-help-menu:after-about menu dlg-parent) (drracket:app:add-important-urls-to-help-menu menu '()) (new menu-item% + [label (string-constant have-an-issue?)] + [parent menu] + [callback + (λ (x y) + (define result + (message-box/custom + (string-constant drracket) + (string-constant use-github-or-the-mailing-list-for-issues) + (string-constant visit-github) + (string-constant visit-mailing-list) + #f + #:dialog-mixin frame:focus-table-mixin)) + (case result + [(1) (send-url "https://github.com/racket/racket/issues/new")] + [(2) (send-url "https://lists.racket-lang.org/")]))]) + #; + (new menu-item% [label (string-constant bug-report-submit-menu-item)] [parent menu] [callback diff -Nru racket-7.2+ppa2/share/pkgs/drracket/drracket/private/module-language.rkt racket-7.3+ppa1/share/pkgs/drracket/drracket/private/module-language.rkt --- racket-7.2+ppa2/share/pkgs/drracket/drracket/private/module-language.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/drracket/drracket/private/module-language.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -550,7 +550,7 @@ (create-embedding-executable exe-name #:gracket? gui? - #:aux (cons '(subsystem . console) aux) + #:aux aux #:verbose? #f #:modules (list (list #f program-filename)) #:configure-via-first-module? #t diff -Nru racket-7.2+ppa2/share/pkgs/drracket/info.rkt racket-7.3+ppa1/share/pkgs/drracket/info.rkt --- racket-7.2+ppa2/share/pkgs/drracket/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/drracket/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.35") ("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" "quickscript"))) (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.3"))) (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.23") "typed-racket-lib" "wxme-lib" ("gui-lib" #:version "1.35") ("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" "quickscript"))) (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-7.2+ppa2/share/pkgs/drracket-plugin-lib/info.rkt racket-7.3+ppa1/share/pkgs/drracket-plugin-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/drracket-plugin-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/drracket-plugin-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/drracket-tool/info.rkt racket-7.3+ppa1/share/pkgs/drracket-tool/info.rkt --- racket-7.2+ppa2/share/pkgs/drracket-tool/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/drracket-tool/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/drracket-tool-doc/info.rkt racket-7.3+ppa1/share/pkgs/drracket-tool-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/drracket-tool-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/drracket-tool-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/drracket-tool-lib/drracket/private/syncheck/traversals.rkt racket-7.3+ppa1/share/pkgs/drracket-tool-lib/drracket/private/syncheck/traversals.rkt --- racket-7.2+ppa2/share/pkgs/drracket-tool-lib/drracket/private/syncheck/traversals.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/drracket-tool-lib/drracket/private/syncheck/traversals.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -232,8 +232,10 @@ [collect-general-info (λ (stx) (add-origins stx varrefs level-of-enclosing-module) - (add-disappeared-bindings stx binders varrefs level-of-enclosing-module) - (add-disappeared-uses stx varrefs level-of-enclosing-module) + (add-disappeared-bindings stx binders sub-identifier-binding-directives varrefs + level level-of-enclosing-module mods) + (add-disappeared-uses stx varrefs sub-identifier-binding-directives + level level-of-enclosing-module mods) (add-mouse-over-tooltips stx) (add-sub-range-binders stx sub-identifier-binding-directives @@ -630,7 +632,8 @@ (vector-ref prop 3))]))) ;; add-disappeared-bindings : syntax id-set integer -> void - (define (add-disappeared-bindings stx binders disappaeared-uses level-of-enclosing-module) + (define (add-disappeared-bindings stx binders sub-identifier-binding-directives disappeared-uses + level level-of-enclosing-module mods) (let ([prop (syntax-property stx 'disappeared-binding)]) (when prop (let loop ([prop prop]) @@ -639,11 +642,13 @@ (loop (car prop)) (loop (cdr prop))] [(identifier? prop) - (add-origins prop disappaeared-uses level-of-enclosing-module) - (add-id binders prop level-of-enclosing-module)]))))) + (add-origins prop disappeared-uses level-of-enclosing-module) + (add-binders prop binders #f #f level level-of-enclosing-module + sub-identifier-binding-directives mods)]))))) ;; add-disappeared-uses : syntax id-set integer -> void - (define (add-disappeared-uses stx id-set level-of-enclosing-module) + (define (add-disappeared-uses stx id-set sub-identifier-binding-directives + level level-of-enclosing-module mods) (let ([prop (syntax-property stx 'disappeared-use)]) (when prop (let loop ([prop prop]) @@ -652,6 +657,8 @@ (loop (car prop)) (loop (cdr prop))] [(identifier? prop) + (add-sub-range-binders prop sub-identifier-binding-directives + level level-of-enclosing-module mods) (add-id id-set prop level-of-enclosing-module)]))))) ;; annotate-variables : namespace directory string id-set[four of them] @@ -766,7 +773,7 @@ (match-define (vector binding-id to-start to-span to-dx to-dy new-binding-id from-start from-span from-dx from-dy) directive) - (define all-varrefs (lookup-phase-to-mapping phase-to-varrefs (list phase-level mods))) + (define all-varrefs (lookup-phase-to-mapping phase-to-varrefs (list phase-level mods) phase-level)) (define all-binders (lookup-phase-to-mapping phase-to-binders phase-level)) (define varrefs (get-ids all-varrefs binding-id)) (when varrefs diff -Nru racket-7.2+ppa2/share/pkgs/drracket-tool-lib/info.rkt racket-7.3+ppa1/share/pkgs/drracket-tool-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/drracket-tool-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/drracket-tool-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/ds-store/info.rkt racket-7.3+ppa1/share/pkgs/ds-store/info.rkt --- racket-7.2+ppa2/share/pkgs/ds-store/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/ds-store/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/ds-store-doc/info.rkt racket-7.3+ppa1/share/pkgs/ds-store-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/ds-store-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/ds-store-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/ds-store-lib/info.rkt racket-7.3+ppa1/share/pkgs/ds-store-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/ds-store-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/ds-store-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/dynext-lib/info.rkt racket-7.3+ppa1/share/pkgs/dynext-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/dynext-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/dynext-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/eli-tester/info.rkt racket-7.3+ppa1/share/pkgs/eli-tester/info.rkt --- racket-7.2+ppa2/share/pkgs/eli-tester/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/eli-tester/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (define collection (quote multi)) (define deps (quote ("base" "rackunit-lib"))) (define pkg-desc "Testing framework") (define pkg-authors (quote (eli))))) diff -Nru racket-7.2+ppa2/share/pkgs/eopl/info.rkt racket-7.3+ppa1/share/pkgs/eopl/info.rkt --- racket-7.2+ppa2/share/pkgs/eopl/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/eopl/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/errortrace/info.rkt racket-7.3+ppa1/share/pkgs/errortrace/info.rkt --- racket-7.2+ppa2/share/pkgs/errortrace/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/errortrace/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/errortrace-doc/info.rkt racket-7.3+ppa1/share/pkgs/errortrace-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/errortrace-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/errortrace-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/errortrace-lib/errortrace/stacktrace.rkt racket-7.3+ppa1/share/pkgs/errortrace-lib/errortrace/stacktrace.rkt --- racket-7.2+ppa2/share/pkgs/errortrace-lib/errortrace/stacktrace.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/errortrace-lib/errortrace/stacktrace.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -662,7 +662,7 @@ (parameterize ([current-recover-table (make-hash)]) (no-cache-annotate-top expr phase))) (define (no-cache-annotate-named name expr phase) - ((make-annotate #t name) expr phase)) + ((make-annotate #f name) expr phase)) (define (annotate-named name expr phase) (parameterize ([current-recover-table (make-hash)]) (no-cache-annotate-named name expr phase)))) diff -Nru racket-7.2+ppa2/share/pkgs/errortrace-lib/info.rkt racket-7.3+ppa1/share/pkgs/errortrace-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/errortrace-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/errortrace-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/frtime/info.rkt racket-7.3+ppa1/share/pkgs/frtime/info.rkt --- racket-7.2+ppa2/share/pkgs/frtime/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/frtime/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/future-visualizer/info.rkt racket-7.3+ppa1/share/pkgs/future-visualizer/info.rkt --- racket-7.2+ppa2/share/pkgs/future-visualizer/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/future-visualizer/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/future-visualizer-typed/info.rkt racket-7.3+ppa1/share/pkgs/future-visualizer-typed/info.rkt --- racket-7.2+ppa2/share/pkgs/future-visualizer-typed/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/future-visualizer-typed/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/games/info.rkt racket-7.3+ppa1/share/pkgs/games/info.rkt --- racket-7.2+ppa2/share/pkgs/games/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/games/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/gui/info.rkt racket-7.3+ppa1/share/pkgs/gui/info.rkt --- racket-7.2+ppa2/share/pkgs/gui/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/gui/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/gui-doc/info.rkt racket-7.3+ppa1/share/pkgs/gui-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/gui-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/gui-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/gui-doc/scribblings/gui/miscwin-funcs.scrbl racket-7.3+ppa1/share/pkgs/gui-doc/scribblings/gui/miscwin-funcs.scrbl --- racket-7.2+ppa2/share/pkgs/gui-doc/scribblings/gui/miscwin-funcs.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/gui-doc/scribblings/gui/miscwin-funcs.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -121,7 +121,9 @@ on some platforms (e.g., when nested in a @racket[group-box-panel%]), so the result is no longer guaranteed to be related to a @racket[panel%]'s color. -} + +See @racket[get-label-background-color] for a closer approximation to +a panel background.} @defproc[(get-highlight-background-color) (is-a?/c color%)]{ @@ -135,6 +137,32 @@ selected text is drawn with its usual color.} +@defproc[(get-label-background-color) (is-a?/c color%)]{ + +Returns an approximation of the color that is likely to appear behind +a control label. This color may not match the actual color of a +control's background, since themes on some platforms may vary the color +for different contexts. + +See also @racket[get-label-foreground-color]. + +@history[#:added "1.38"]} + + +@defproc[(get-label-foreground-color) (is-a?/c color%)]{ + +Returns an approximation of the color that is likely to be used for +the text of a control label. This color may not match the actual color +of label text, since themes on some platforms may vary the color for +different contexts. + +Comparing the results of @racket[get-label-foreground-color] and +@racket[get-label-background-color] may be useful for detecting +whether a platform's current theme is ``dark mode'' versus ``light +mode.'' + +@history[#:added "1.38"]} + @defproc[(get-window-text-extent [string string?] [font (is-a?/c font%)] [combine? any/c #f]) diff -Nru racket-7.2+ppa2/share/pkgs/gui-lib/framework/private/autocomplete.rkt racket-7.3+ppa1/share/pkgs/gui-lib/framework/private/autocomplete.rkt --- racket-7.2+ppa2/share/pkgs/gui-lib/framework/private/autocomplete.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/gui-lib/framework/private/autocomplete.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -3,6 +3,9 @@ (require racket/class racket/match) (provide autocompletion-cursor<%> autocompletion-cursor%) +(module+ test + (require rackunit)) + (define autocompletion-cursor<%> (interface () get-completions ; -> (listof string) @@ -38,6 +41,14 @@ [else c]))])) (length parts))) +(define better-completion? + (match-lambda** + [((cons w r) (cons w* r*)) + (cond + [(not (= r r*)) (> r r*)] + ;; prefer shorter matches + [else (< (string-length w) (string-length w*))])])) + ;; ============================================================ ;; autocompletion-cursor<%> implementation @@ -65,10 +76,7 @@ [r (in-value (rnk w))] #:when (>= r mx)) (cons w r)) - (match-lambda** [((cons w r) (cons w* r*)) - (or (> r r*) - ;; prefer shorter matches - (< (string-length w) (string-length w*)))])))) + better-completion?))) (define all-completions-length (length all-completions)) @@ -91,3 +99,22 @@ (define/public (empty?) (eq? (get-length) 0)) (super-new))) + +(module+ test + (define rnk + (let-values ([(rnk _) (rank "define-syntax-")]) + (λ (completion) + (cons completion (rnk completion))))) + + (check-equal? (better-completion? (rnk "define-syntax-rule") (rnk "syntax")) + #t) + + (check-equal? (better-completion? (rnk "syntax") (rnk "define-syntax-rule")) + #f) + + (check-equal? (better-completion? (rnk "define-syntax") (rnk "syntax")) + #t) + + (check-equal? (better-completion? (rnk "syntax") (rnk "define-syntax")) + #f) + ) diff -Nru racket-7.2+ppa2/share/pkgs/gui-lib/framework/private/color-prefs.rkt racket-7.3+ppa1/share/pkgs/gui-lib/framework/private/color-prefs.rkt --- racket-7.2+ppa2/share/pkgs/gui-lib/framework/private/color-prefs.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/gui-lib/framework/private/color-prefs.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -109,10 +109,10 @@ smoothed unsmoothed)) (define smoothing-option-strings - '("Default" - "Partly smoothed" - "Smoothed" - "Unsmoothed")) + (list (string-constant cs-smoothing-default) + (string-constant cs-smoothing-partial) + (string-constant cs-smoothing-full) + (string-constant cs-smoothing-none))) (define (smoothing->index s) (let loop ([i 0] diff -Nru racket-7.2+ppa2/share/pkgs/gui-lib/framework/private/color.rkt racket-7.3+ppa1/share/pkgs/gui-lib/framework/private/color.rkt --- racket-7.2+ppa2/share/pkgs/gui-lib/framework/private/color.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/gui-lib/framework/private/color.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -19,7 +19,8 @@ "../preferences.rkt" "sig.rkt" "aspell.rkt" - "color-local-member-name.rkt") + "color-local-member-name.rkt" + "inline-overview.rkt") (provide color@) (define-unit color@ @@ -594,16 +595,19 @@ (define/private (colorer-callback) (cond - ((is-locked?) - (set! restart-callback #t)) - (else - (cond - [(in-edit-sequence?) - (set! continue-after-edit-sequence? #t)] - [else - (colorer-driver) - (unless (andmap lexer-state-up-to-date? lexer-states) - (queue-callback (λ () (colorer-callback)) #f))])))) + [(is-locked?) + (set! restart-callback #t)] + [(in-edit-sequence?) + (set! continue-after-edit-sequence? #t)] + [(and (is-a? this inline-overview<%>) + (send this is-inline-overview-work-pending?)) + ;; wait for the overview to finish building its bitmap + ;; this seems to look nicer when opening a new file + (queue-callback (λ () (colorer-callback)) #f)] + [else + (colorer-driver) + (unless (andmap lexer-state-up-to-date? lexer-states) + (queue-callback (λ () (colorer-callback)) #f))])) ;; Must not be called when the editor is locked (define/private (finish-now) diff -Nru racket-7.2+ppa2/share/pkgs/gui-lib/framework/private/frame.rkt racket-7.3+ppa1/share/pkgs/gui-lib/framework/private/frame.rkt --- racket-7.2+ppa2/share/pkgs/gui-lib/framework/private/frame.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/gui-lib/framework/private/frame.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -999,11 +999,12 @@ (when (< cw tw) (min-client-width (inexact->exact (ceiling tw))))))) (define/override (on-paint) - (let ([dc (get-dc)]) - (send dc set-font normal-control-font) - (let-values ([(cw ch) (get-client-size)] - [(tw th _1 _2) (send dc get-text-extent str)]) - (send dc draw-text str 0 (/ (- ch th) 2))))) + (define dc (get-dc)) + (send dc set-font normal-control-font) + (send dc set-text-foreground (get-label-foreground-color)) + (define-values (cw ch) (get-client-size)) + (define-values (tw th _1 _2) (send dc get-text-extent str)) + (send dc draw-text str 0 (/ (- ch th) 2))) (define/override (on-event evt) (when button-up (when (send evt button-up?) @@ -2891,7 +2892,7 @@ (- (/ ch 2) (/ indicator-height 2)))) (cond [on? - (send dc set-text-foreground (send the-color-database find-color "black")) + (send dc set-text-foreground (get-label-foreground-color)) (draw-p)] [mouse-over? (send dc set-brush (if mouse-down? "blue" "skyblue") 'solid) diff -Nru racket-7.2+ppa2/share/pkgs/gui-lib/framework/private/inline-overview.rkt racket-7.3+ppa1/share/pkgs/gui-lib/framework/private/inline-overview.rkt --- racket-7.2+ppa2/share/pkgs/gui-lib/framework/private/inline-overview.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/gui-lib/framework/private/inline-overview.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -24,7 +24,9 @@ (define inline-overview<%> (interface ((class->interface text%)) get-inline-overview-enabled? - set-inline-overview-enabled?)) + set-inline-overview-enabled? + is-inline-overview-work-pending? + )) (define inline-overview-mixin (mixin ((class->interface text%)) (inline-overview<%>) (define is-do-a-little-work-enqueued? #f) @@ -38,6 +40,8 @@ ;; the lines after and including known-blank are known to be blank in the bitmap (define known-blank +inf.0) + (define/public (is-inline-overview-work-pending?) is-do-a-little-work-enqueued?) + (define/public (get-inline-overview-enabled?) enabled?) (define/public (set-inline-overview-enabled? _e?) (define e? (and _e? #t)) diff -Nru racket-7.2+ppa2/share/pkgs/gui-lib/framework/private/text.rkt racket-7.3+ppa1/share/pkgs/gui-lib/framework/private/text.rkt --- racket-7.2+ppa2/share/pkgs/gui-lib/framework/private/text.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/gui-lib/framework/private/text.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -3990,6 +3990,7 @@ (let ([reasonable? (send completions-box widen)]) (cond [reasonable? + (set! word-end-pos (sub1 word-end-pos)) (let-values ([(_ __ x1p y1p) (send completions-box get-menu-coordinates)]) (invalidate-bitmap-cache x0 y0 (max x1 x1p) (max y1 y1p)))] [else diff -Nru racket-7.2+ppa2/share/pkgs/gui-lib/info.rkt racket-7.3+ppa1/share/pkgs/gui-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/gui-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/gui-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (define collection (quote multi)) (define deps (quote ("srfi-lite-lib" "data-lib" "icons" ("base" #:version "7.0.0.19") "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.37"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.3"))) (define collection (quote multi)) (define deps (quote ("srfi-lite-lib" "data-lib" "icons" ("base" #:version "7.0.0.19") "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.22") "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.38"))) diff -Nru racket-7.2+ppa2/share/pkgs/gui-lib/mred/mred-sig.rkt racket-7.3+ppa1/share/pkgs/gui-lib/mred/mred-sig.rkt --- racket-7.2+ppa2/share/pkgs/gui-lib/mred/mred-sig.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/gui-lib/mred/mred-sig.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -98,6 +98,8 @@ get-ps-setup-from-user get-highlight-background-color get-highlight-text-color +get-label-background-color +get-label-foreground-color get-resource get-text-from-user get-the-editor-data-class-list diff -Nru racket-7.2+ppa2/share/pkgs/gui-lib/mred/private/mred.rkt racket-7.3+ppa1/share/pkgs/gui-lib/mred/private/mred.rkt --- racket-7.2+ppa2/share/pkgs/gui-lib/mred/private/mred.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/gui-lib/mred/private/mred.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -123,6 +123,8 @@ get-current-mouse-state get-highlight-background-color get-highlight-text-color + get-label-foreground-color + get-label-background-color get-the-editor-data-class-list is-busy? is-color-display? diff -Nru racket-7.2+ppa2/share/pkgs/gui-lib/mred/private/wx/cocoa/platform.rkt racket-7.3+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/platform.rkt --- racket-7.2+ppa2/share/pkgs/gui-lib/mred/private/wx/cocoa/platform.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/platform.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -88,6 +88,8 @@ any-control+alt-is-altgr get-highlight-background-color get-highlight-text-color + get-label-foreground-color + get-label-background-color make-screen-bitmap make-gl-bitmap check-for-break diff -Nru racket-7.2+ppa2/share/pkgs/gui-lib/mred/private/wx/cocoa/procs.rkt racket-7.3+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/procs.rkt --- racket-7.2+ppa2/share/pkgs/gui-lib/mred/private/wx/cocoa/procs.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/procs.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -53,6 +53,8 @@ can-show-print-setup? get-highlight-background-color get-highlight-text-color + get-label-foreground-color + get-label-background-color check-for-break) display-bitmap-resolution make-screen-bitmap @@ -177,10 +179,9 @@ (define-cocoa NSDeviceRGBColorSpace _id) -(define (get-highlight-background-color) +(define (get-color get) (let ([hi (as-objc-allocation-with-retain - (tell (tell NSColor selectedTextBackgroundColor) - colorUsingColorSpaceName: NSDeviceRGBColorSpace))] + (tell (get) colorUsingColorSpaceName: NSDeviceRGBColorSpace))] [as-color (lambda (v) (inexact->exact (floor (* 255.0 v))))]) (begin0 @@ -193,6 +194,20 @@ (tell #:type _CGFloat hi blueComponent))) (release hi)))) +(define (get-highlight-background-color) + (get-color (lambda () (tell NSColor selectedTextBackgroundColor)))) + +(define (get-label-foreground-color) + (get-color (lambda () (tell NSColor labelColor)))) + +(define (get-label-background-color) + (get-color (lambda () + (if (version-10.14-or-later?) + ;; Doesn't seem like a usefule result before Mojave: + (tell NSColor windowBackgroundColor) + ;; Seems like accurate than other option for Mojave: + (tell NSColor controlBackgroundColor))))) + (define (get-highlight-text-color) #f) diff -Nru racket-7.2+ppa2/share/pkgs/gui-lib/mred/private/wx/cocoa/utils.rkt racket-7.3+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/utils.rkt --- racket-7.2+ppa2/share/pkgs/gui-lib/mred/private/wx/cocoa/utils.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/gui-lib/mred/private/wx/cocoa/utils.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -87,17 +87,17 @@ (define old-cocoa? ; earlier than 10.5? (NSAppKitVersionNumber . < . 949)) -(define (version-10.6-or-later?) +(define (version-10.6-or-later?) ; Snow Leopard (NSAppKitVersionNumber . >= . 1038)) -(define (version-10.7-or-later?) +(define (version-10.7-or-later?) ; Lion (NSAppKitVersionNumber . >= . 1138)) -(define (version-10.9-or-later?) +(define (version-10.9-or-later?) ; Mavericks (NSAppKitVersionNumber . >= . 1265)) -(define (version-10.10-or-later?) +(define (version-10.10-or-later?) ; Yosemite (NSAppKitVersionNumber . >= . 1331)) -(define (version-10.11-or-later?) +(define (version-10.11-or-later?) ; El Capitan (NSAppKitVersionNumber . >= . 1404)) -(define (version-10.13-or-later?) +(define (version-10.13-or-later?) ; High Sierra (NSAppKitVersionNumber . >= . 1561)) -(define (version-10.14-or-later?) +(define (version-10.14-or-later?) ; Mojave (NSAppKitVersionNumber . >= . 1671)) diff -Nru racket-7.2+ppa2/share/pkgs/gui-lib/mred/private/wx/gtk/platform.rkt racket-7.3+ppa1/share/pkgs/gui-lib/mred/private/wx/gtk/platform.rkt --- racket-7.2+ppa2/share/pkgs/gui-lib/mred/private/wx/gtk/platform.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/gui-lib/mred/private/wx/gtk/platform.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -89,6 +89,8 @@ any-control+alt-is-altgr get-highlight-background-color get-highlight-text-color + get-label-foreground-color + get-label-background-color make-screen-bitmap make-gl-bitmap check-for-break diff -Nru racket-7.2+ppa2/share/pkgs/gui-lib/mred/private/wx/gtk/procs.rkt racket-7.3+ppa1/share/pkgs/gui-lib/mred/private/wx/gtk/procs.rkt --- racket-7.2+ppa2/share/pkgs/gui-lib/mred/private/wx/gtk/procs.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/gui-lib/mred/private/wx/gtk/procs.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -43,6 +43,8 @@ can-show-print-setup? get-highlight-background-color get-highlight-text-color + get-label-background-color + get-label-foreground-color check-for-break) file-selector show-print-setup @@ -154,6 +156,14 @@ #f (make-object color% r g b)))) +(define (get-label-background-color) + (let-values ([(r g b) (get-label-bg-color)]) + (make-object color% r g b))) + +(define (get-label-foreground-color) + (let-values ([(r g b) (get-label-fg-color)]) + (make-object color% r g b))) + (define/top (make-screen-bitmap [exact-positive-integer? w] [exact-positive-integer? h]) (if (and (eq? 'unix (system-type)) diff -Nru racket-7.2+ppa2/share/pkgs/gui-lib/mred/private/wx/gtk/style.rkt racket-7.3+ppa1/share/pkgs/gui-lib/mred/private/wx/gtk/style.rkt --- racket-7.2+ppa2/share/pkgs/gui-lib/mred/private/wx/gtk/style.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/gui-lib/mred/private/wx/gtk/style.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -6,7 +6,9 @@ (provide (protect-out get-selected-text-color - get-selected-background-color)) + get-selected-background-color + get-label-fg-color + get-label-bg-color)) (define-cstruct _GTypeInstance ([class _pointer])) @@ -88,3 +90,9 @@ (define (get-selected-background-color) (extract-color-values (GtkStyle-base4 the-text-style))) + +(define (get-label-fg-color) + (extract-color-values (GtkStyle-text1 the-text-style))) + +(define (get-label-bg-color) + (extract-color-values (GtkStyle-bg1 the-text-style))) diff -Nru racket-7.2+ppa2/share/pkgs/gui-lib/mred/private/wx/platform.rkt racket-7.3+ppa1/share/pkgs/gui-lib/mred/private/wx/platform.rkt --- racket-7.2+ppa2/share/pkgs/gui-lib/mred/private/wx/platform.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/gui-lib/mred/private/wx/platform.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -78,6 +78,8 @@ any-control+alt-is-altgr get-highlight-background-color get-highlight-text-color + get-label-foreground-color + get-label-background-color make-screen-bitmap make-gl-bitmap check-for-break diff -Nru racket-7.2+ppa2/share/pkgs/gui-lib/mred/private/wx/win32/platform.rkt racket-7.3+ppa1/share/pkgs/gui-lib/mred/private/wx/win32/platform.rkt --- racket-7.2+ppa2/share/pkgs/gui-lib/mred/private/wx/win32/platform.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/gui-lib/mred/private/wx/win32/platform.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -90,6 +90,8 @@ any-control+alt-is-altgr get-highlight-background-color get-highlight-text-color + get-label-foreground-color + get-label-background-color make-screen-bitmap make-gl-bitmap check-for-break diff -Nru racket-7.2+ppa2/share/pkgs/gui-lib/mred/private/wx/win32/procs.rkt racket-7.3+ppa1/share/pkgs/gui-lib/mred/private/wx/win32/procs.rkt --- racket-7.2+ppa2/share/pkgs/gui-lib/mred/private/wx/win32/procs.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/gui-lib/mred/private/wx/win32/procs.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -42,6 +42,8 @@ can-show-print-setup? get-highlight-background-color get-highlight-text-color + get-label-foreground-color + get-label-background-color check-for-break) flush-display get-current-mouse-state @@ -74,10 +76,6 @@ (define (font-from-user-platform-mode) #f) (define-unimplemented get-font-from-user) -(define (get-panel-background) - (let ([c (GetSysColor COLOR_BTNFACE)]) - (make-object color% (GetRValue c) (GetGValue c) (GetBValue c)))) - (define (register-collecting-blit canvas x y w h on off on-x on-y off-x off-y) (send canvas register-collecting-blit x y w h on off on-x on-y off-x off-y)) (define (unregister-collecting-blit canvas) @@ -104,10 +102,22 @@ (define (get-highlight-background-color) (let ([c (GetSysColor COLOR_HIGHLIGHT)]) (make-object color% (GetRValue c) (GetGValue c) (GetBValue c)))) + (define (get-highlight-text-color) (let ([c (GetSysColor COLOR_HIGHLIGHTTEXT)]) (make-object color% (GetRValue c) (GetGValue c) (GetBValue c)))) +(define (get-panel-background) + (let ([c (GetSysColor COLOR_BTNFACE)]) + (make-object color% (GetRValue c) (GetGValue c) (GetBValue c)))) + +(define (get-label-background-color) + (get-panel-background)) + +(define (get-label-foreground-color) + (let ([c (GetSysColor COLOR_BTNTEXT)]) + (make-object color% (GetRValue c) (GetGValue c) (GetBValue c)))) + (define/top (make-screen-bitmap [exact-positive-integer? w] [exact-positive-integer? h]) (make-object win32-bitmap% w h #f)) diff -Nru racket-7.2+ppa2/share/pkgs/gui-lib/mred/private/wxme/text.rkt racket-7.3+ppa1/share/pkgs/gui-lib/mred/private/wxme/text.rkt --- racket-7.2+ppa2/share/pkgs/gui-lib/mred/private/wxme/text.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/gui-lib/mred/private/wxme/text.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1873,6 +1873,7 @@ (values (sub1 start) start #t)) (values start end (and (= start startpos) (= end endpos))))]) + (end-streaks '(delayed)) (unless (or (start . >= . end) (start . < . 0) (start . >= . len)) diff -Nru racket-7.2+ppa2/share/pkgs/gui-lib/mrlib/image-core.rkt racket-7.3+ppa1/share/pkgs/gui-lib/mrlib/image-core.rkt --- racket-7.2+ppa2/share/pkgs/gui-lib/mrlib/image-core.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/gui-lib/mrlib/image-core.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -90,7 +90,7 @@ (unless (image? img) (error 'compute-cached-bitmap "expected an image as the first argument, got ~e" img)) (when (is-a? img image<%>) - (send img compute-cached-bitmap)) + (send img compute-cached-bitmap #:create-new-bitmap-if-not-ok? #t)) (void)) ;; a shape is either: @@ -421,15 +421,19 @@ ;; this method is only used by the 'copy' method (define/public (set-cached-bitmap bm) (set! cached-bitmap bm)) - (define/public (compute-cached-bitmap) + (define/public (compute-cached-bitmap #:create-new-bitmap-if-not-ok? + [create-new-bitmap-if-not-ok? #f]) (when use-cached-bitmap? - (unless cached-bitmap + (when (or (not cached-bitmap) + (and create-new-bitmap-if-not-ok? + (not (send cached-bitmap ok?)))) (define-values (w h) (get-size/but-subject-to-max bb)) (set! cached-bitmap (make-bitmap (+ w 1) (+ h 1))) - (define bdc (make-object bitmap-dc% cached-bitmap)) - (send bdc erase) - (render-image this bdc 0 0) - (send bdc set-bitmap #f)))) + (when (send cached-bitmap ok?) + (define bdc (make-object bitmap-dc% cached-bitmap)) + (send bdc erase) + (render-image this bdc 0 0) + (send bdc set-bitmap #f))))) (define/public (set-use-bitmap-cache?! u-b-c?) (set! use-cached-bitmap? u-b-c?) @@ -438,12 +442,20 @@ (define/override (draw dc x y left top right bottom dx dy draw-caret) (compute-cached-bitmap) - + + ;; if the cached bitmap is not ok? that means we probably + ;; ran out of memory trying to allocate it. In that case, + ;; instead of failing, we just draw nothing. Don't try + ;; to fall back to the other drawing method because + ;; of the invariant that if a bitmap is present, we must + ;; use it or drawing nothing to avoid calling into unknown + ;; code in certain contexts (let ([alpha (send dc get-alpha)]) (when (pair? draw-caret) (send dc set-alpha (* alpha .5))) (if use-cached-bitmap? - (send dc draw-bitmap cached-bitmap x y) + (when (send cached-bitmap ok?) + (send dc draw-bitmap cached-bitmap x y)) (render-image this dc x y)) (send dc set-alpha alpha))) diff -Nru racket-7.2+ppa2/share/pkgs/gui-lib/mrlib/name-message.rkt racket-7.3+ppa1/share/pkgs/gui-lib/mrlib/name-message.rkt --- racket-7.2+ppa2/share/pkgs/gui-lib/mrlib/name-message.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/gui-lib/mrlib/name-message.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1,13 +1,13 @@ -#lang racket/gui +#lang racket/base +(require racket/gui/base + racket/contract + racket/class + racket/path + racket/list + "private/panel-wob.rkt") (define (get-left-side-padding) (+ button-label-inset circle-spacer)) (define button-label-inset 1) -(define black-color (make-object color% "BLACK")) - -(define triangle-width 10) -(define triangle-height 14) -(define triangle-color (make-object color% 50 50 50)) - (define border-inset 1) (define circle-spacer 4) (define rrect-spacer 3) @@ -18,7 +18,7 @@ (values number? number? (>=/c 0) (>=/c 0)))] [draw-button-label (->i ([dc (is-a?/c dc<%>)] - [label (or/c false/c string?)] + [label (or/c #f string?)] [x number?] [y number?] [w number?] @@ -26,11 +26,11 @@ [mouse-over? boolean?] [grabbed? boolean?] [button-label-font (is-a?/c font%)] - [bkg-color (or/c false/c (is-a?/c color%) string?)]) + [bkg-color (or/c #f (is-a?/c color%) string?)]) #:pre (w h) (w . > . (- h (* 2 border-inset))) [result void?])] - + [calc-button-min-sizes (->* ((is-a?/c dc<%>) string?) ((is-a?/c font%)) @@ -39,188 +39,183 @@ (provide name-message%) (define name-message% - (class canvas% + (class canvas% (init-field [string-constant-untitled "Untitled"] - [string-constant-no-full-name-since-not-saved + [string-constant-no-full-name-since-not-saved "The file does not have a full name because it has not yet been saved."]) (inherit popup-menu get-dc get-size get-client-size min-width min-height stretchable-width stretchable-height get-top-level-window refresh) - + (define short-title? #f) - + (define hidden? #f) - (define/public (set-hidden? d?) + (define/public (set-hidden? d?) (unless (eq? hidden? d?) (set! hidden? d?) (refresh))) - + (define allow-to-shrink #f) - (define/public (set-allow-shrinking w) + (define/public (set-allow-shrinking w) (unless (eq? w allow-to-shrink) (set! allow-to-shrink w) (set! to-draw-message #f) (update-min-sizes))) - + (define paths #f) - + ;; label : string (init-field [label string-constant-untitled] [font small-control-font]) - + (define/private (get-label) (if short-title? "/" label)) - + (define full-name-window #f) - + (define mouse-grabbed? #f) (define mouse-over? #f) - + (define/public (on-choose-directory dir) (void)) - + ;; set-message : boolean (union #f path string) -> void ;; if file-name? is #t, path-name should be a path (or #f) ;; if file-name? is #f, path-name should be a string (or #f) (define/public (set-message file-name? path-name) - (set! paths (if (and file-name? - path-name + (set! paths (if (and file-name? + path-name (file-exists? path-name)) (map path->string (explode-path (simple-form-path path-name))) #f)) - (let ([new-label (cond - [(and paths (not (null? paths))) (last paths)] - [path-name path-name] - [else string-constant-untitled])]) - (unless (equal? label new-label) - (set! label new-label) - (set! to-draw-message #f) - (update-min-sizes) - (refresh)))) - - (define/public (set-short-title st?) + (define new-label + (cond + [(and paths (not (null? paths))) (last paths)] + [path-name path-name] + [else string-constant-untitled])) + (unless (equal? label new-label) + (set! label new-label) + (set! to-draw-message #f) + (update-min-sizes) + (refresh))) + + (define/public (set-short-title st?) (set! short-title? st?) (set! to-draw-message #f) (update-min-sizes) (refresh)) - + (define/public (fill-popup menu reset) (if (and paths (not (null? paths))) (let loop ([paths (cdr (reverse paths))]) (cond [(null? paths) (void)] - [else + [else (make-object menu-item% (car paths) menu (lambda (evt item) (reset) (on-choose-directory (apply build-path (reverse paths))))) (loop (cdr paths))])) - (let ([i (make-object menu-item% + (let ([i (make-object menu-item% string-constant-no-full-name-since-not-saved menu void)]) (send i enable #f)))) - + (define/override (on-event evt) (unless hidden? - (let-values ([(max-x max-y) (get-size)]) - (let ([inside? (and (not (send evt leaving?)) - (<= 0 (send evt get-x) max-x) - (<= 0 (send evt get-y) max-y))]) - (unless (eq? inside? mouse-over?) - (set! mouse-over? inside?) - (refresh)))) - + (define-values (max-x max-y) (get-size)) + (define inside? + (and (not (send evt leaving?)) + (<= 0 (send evt get-x) max-x) + (<= 0 (send evt get-y) max-y))) + (unless (eq? inside? mouse-over?) + (set! mouse-over? inside?) + (refresh)) + (cond [(send evt button-down?) - (let-values ([(width height) (get-size)] - [(reset) (lambda () - (set! mouse-grabbed? #f) - (set! mouse-over? #f) - (refresh))]) - (set! mouse-over? #t) - (set! mouse-grabbed? #t) - (let ([menu (make-object popup-menu% #f - (lambda x - (reset)))]) - (fill-popup menu reset) - - ;; Refresh the screen (wait for repaint) - (set! paint-sema (make-semaphore)) - (refresh) - (yield paint-sema) - (set! paint-sema #f) - - ;; Popup menu - (popup-menu menu - 0 - height)))]))) - + (define-values (width height) (get-size)) + (define (reset) + (set! mouse-grabbed? #f) + (set! mouse-over? #f) + (refresh)) + (set! mouse-over? #t) + (set! mouse-grabbed? #t) + (define menu + (make-object popup-menu% #f + (lambda x + (reset)))) + (fill-popup menu reset) + + ;; Refresh the screen (wait for repaint) + (set! paint-sema (make-semaphore)) + (refresh) + (yield paint-sema) + (set! paint-sema #f) + + ;; Popup menu + (popup-menu menu + 0 + height)]))) + (define paint-sema #f) - + (inherit get-parent) (define/private (update-min-sizes) - (let-values ([(w h) (calc-button-min-sizes (get-dc) (get-label) font)]) - (cond - [allow-to-shrink - (cond - [(< w allow-to-shrink) - (stretchable-width #f) - (min-width w)] - [else - (stretchable-width #t) - (min-width allow-to-shrink)])] - [else - (min-width w)]) - (min-height h) - (send (get-parent) reflow-container))) - + (define-values (w h) (calc-button-min-sizes (get-dc) (get-label) font)) + (cond + [allow-to-shrink + (cond + [(< w allow-to-shrink) + (stretchable-width #f) + (min-width w)] + [else + (stretchable-width #t) + (min-width allow-to-shrink)])] + [else + (min-width w)]) + (min-height h) + (send (get-parent) reflow-container)) + (define/override (on-paint) (when paint-sema (semaphore-post paint-sema)) (unless to-draw-message (compute-new-string)) - (let ([dc (get-dc)]) - (let-values ([(w h) (get-client-size)]) - (cond - [hidden? - #; - (let ([pen (send dc get-pen)] - [brush (send dc get-brush)]) - (send dc set-brush (send the-brush-list find-or-create-brush (get-panel-background) 'panel)) - (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) - (send dc draw-rectangle 0 0 w h) - (send dc set-pen pen) - (send dc set-brush brush))] - [else - (when (and (> w 5) (> h 5)) - (draw-button-label dc to-draw-message 0 0 w h mouse-over? mouse-grabbed? font (get-background-color)))])))) - + (define dc (get-dc)) + (define-values (w h) (get-client-size)) + (unless hidden? + (when (and (> w 5) (> h 5)) + (draw-button-label dc to-draw-message 0 0 w h mouse-over? mouse-grabbed? + font (get-background-color))))) + (define/public (get-background-color) #f) - + (define to-draw-message #f) (define/private (compute-new-string) - (let ([label (get-label)]) - (let-values ([(cw ch) (get-client-size)]) - (let ([width-to-use (- cw (get-left-side-padding) triangle-width circle-spacer)]) - (let loop ([c (string-length label)]) - (cond - [(= c 0) (set! to-draw-message "")] - [else - (let ([candidate (if (= c (string-length label)) - label - (string-append (substring label 0 c) "..."))]) - (let-values ([(tw th _1 _2) (send (get-dc) get-text-extent candidate small-control-font)]) - (cond - [(tw . <= . width-to-use) (set! to-draw-message candidate)] - [else - (loop (- c 1))])))])))))) - + (define label (get-label)) + (define-values (cw ch) (get-client-size)) + (define width-to-use (- cw (get-left-side-padding) triangle-width circle-spacer)) + (let loop ([c (string-length label)]) + (cond + [(= c 0) (set! to-draw-message "")] + [else + (define candidate (if (= c (string-length label)) + label + (string-append (substring label 0 c) "..."))) + (define-values (tw th _1 _2) + (send (get-dc) get-text-extent candidate small-control-font)) + (cond + [(tw . <= . width-to-use) (set! to-draw-message candidate)] + [else + (loop (- c 1))])]))) + (define/override (on-size w h) (compute-new-string) (refresh)) - + (super-new [style '(transparent no-focus)]) (update-min-sizes) (stretchable-width #f) @@ -236,105 +231,132 @@ (define mouse-over-color (case (system-type) [(macosx) "darkgray"] [else (make-object color% 230 230 230)])) +(define mouse-over-color-white-on-black (make-object color% 20 20 20)) +(define (get-mouse-over-color) (if (white-on-black-panel-scheme?) + mouse-over-color-white-on-black + mouse-over-color)) (define mouse-grabbed-color (make-object color% 100 100 100)) +(define mouse-grabbed-color-white-on-black (make-object color% 155 155 155)) +(define (get-mouse-grabbed-color) + (if (white-on-black-panel-scheme?) + mouse-grabbed-color-white-on-black + mouse-grabbed-color)) (define grabbed-fg-color (make-object color% 220 220 220)) +(define grabbed-fg-color-white-on-black (make-object color% 30 30 30)) +(define (get-grabbed-fg-color) + (if (white-on-black-panel-scheme?) + grabbed-fg-color-white-on-black + grabbed-fg-color)) + +(define triangle-width 10) +(define triangle-height 14) +(define triangle-color (make-object color% 50 50 50)) +(define triangle-color-white-on-black (make-object color% 200 200 200)) +(define (get-triangle-color) + (if (white-on-black-panel-scheme?) + triangle-color-white-on-black + triangle-color)) (define (calc-button-min-sizes dc label [button-label-font (send dc get-font)]) - (let-values ([(w h a d) (send dc get-text-extent label button-label-font)]) - (let-values ([(px py pw ph) (pad-xywh 0 0 w h)]) - (values pw ph)))) + (define-values (w h a d) (send dc get-text-extent label button-label-font)) + (define-values (px py pw ph) (pad-xywh 0 0 w h)) + (values pw ph)) (define (pad-xywh tx ty tw th) - (let* ([ans-h - (+ button-label-inset - (max 0 - (+ 2 (inexact->exact (ceiling th))) - (+ 2 triangle-height)) - button-label-inset)] - [ans-w - (+ border-inset - circle-spacer - button-label-inset - (if (eq? (system-type) 'windows) 1 0) ;; because "(define ...)" has the wrong size under windows - (max 0 (inexact->exact (ceiling tw))) - button-label-inset - triangle-width - circle-spacer - border-inset)]) - (values - (- tx (quotient (ceiling (- ans-w tw)) 2)) - (- ty (quotient (ceiling (- ans-h th)) 2)) - ans-w - ans-h))) + (define ans-h + (+ button-label-inset + (max 0 + (+ 2 (inexact->exact (ceiling th))) + (+ 2 triangle-height)) + button-label-inset)) + (define ans-w + (+ border-inset + circle-spacer + button-label-inset + ;; because "(define ...)" has the wrong size under windows + (if (eq? (system-type) 'windows) 1 0) + (max 0 (inexact->exact (ceiling tw))) + button-label-inset + triangle-width + circle-spacer + border-inset)) + (values + (- tx (quotient (ceiling (- ans-w tw)) 2)) + (- ty (quotient (ceiling (- ans-h th)) 2)) + ans-w + ans-h)) (define (draw-button-label dc label dx dy full-w h mouse-over? grabbed? button-label-font bkg-color) - + (define label-width (if label (let-values ([(w _1 _2 _3) (send dc get-text-extent label button-label-font)]) w) 0)) - - (define w (+ border-inset circle-spacer button-label-inset label-width button-label-inset triangle-width circle-spacer border-inset)) + + (define w (+ border-inset circle-spacer button-label-inset label-width + button-label-inset triangle-width circle-spacer border-inset)) (when (and bkg-color (and (not (or mouse-over? grabbed?)))) (send dc set-pen bkg-color 1 'solid) (send dc set-brush bkg-color 'solid) (send dc draw-rectangle dx dy w h)) - + (when (or mouse-over? grabbed?) - (let ([color (if grabbed? - mouse-grabbed-color - mouse-over-color)] - [xh (- h (* 2 border-inset))]) - (case (system-type) - [(macosx) - (send dc set-pen (send the-pen-list find-or-create-pen color 1 'solid)) - (send dc set-brush (send the-brush-list find-or-create-brush color 'solid)) - - (send dc draw-ellipse (+ dx border-inset) (+ dy border-inset) xh xh) - (send dc draw-ellipse (+ dx (- w xh)) (+ dy border-inset) xh xh) - - (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) - (send dc draw-rectangle (+ dx (quotient xh 2)) (+ dy border-inset) (- w xh) xh) - (send dc set-pen (send the-pen-list find-or-create-pen color 1 'solid)) - (send dc draw-line - (+ dx (quotient xh 2)) - (+ dy border-inset) - (+ dx (- w (quotient xh 2))) - (+ dy border-inset)) - (send dc draw-line - (+ dx (quotient xh 2)) - (+ dy (- h 1 border-inset)) - (+ dx (- w (quotient xh 2))) - (+ dy (- h 1 border-inset)))] - [else - (send dc set-pen (send the-pen-list find-or-create-pen triangle-color 1 'solid)) - (send dc set-brush (send the-brush-list find-or-create-brush color 'solid)) - (send dc draw-rounded-rectangle (+ dx rrect-spacer) (+ dy border-inset) (- w border-inset rrect-spacer) xh 2)]))) - + (define color (if grabbed? + (get-mouse-grabbed-color) + (get-mouse-over-color))) + (define xh (- h (* 2 border-inset))) + (case (system-type) + [(macosx) + (send dc set-pen (send the-pen-list find-or-create-pen color 1 'solid)) + (send dc set-brush (send the-brush-list find-or-create-brush color 'solid)) + + (send dc draw-ellipse (+ dx border-inset) (+ dy border-inset) xh xh) + (send dc draw-ellipse (+ dx (- w xh)) (+ dy border-inset) xh xh) + + (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) + (send dc draw-rectangle (+ dx (quotient xh 2)) (+ dy border-inset) (- w xh) xh) + (send dc set-pen (send the-pen-list find-or-create-pen color 1 'solid)) + (send dc draw-line + (+ dx (quotient xh 2)) + (+ dy border-inset) + (+ dx (- w (quotient xh 2))) + (+ dy border-inset)) + (send dc draw-line + (+ dx (quotient xh 2)) + (+ dy (- h 1 border-inset)) + (+ dx (- w (quotient xh 2))) + (+ dy (- h 1 border-inset)))] + [else + (send dc set-pen (send the-pen-list find-or-create-pen (get-triangle-color) 1 'solid)) + (send dc set-brush (send the-brush-list find-or-create-brush color 'solid)) + (send dc draw-rounded-rectangle + (+ dx rrect-spacer) (+ dy border-inset) + (- w border-inset rrect-spacer) xh 2)])) + (when label - (send dc set-text-foreground (if grabbed? grabbed-fg-color black-color)) + (send dc set-text-foreground (if grabbed? (get-grabbed-fg-color) (get-label-foreground-color))) (send dc set-font button-label-font) - (let-values ([(tw th _1 _2) (send dc get-text-extent label)]) - (send dc draw-text label - (+ dx (+ border-inset circle-spacer button-label-inset)) - (+ dy (- (/ h 2) (/ th 2))) - #t))) - + (define-values (tw th _1 _2) (send dc get-text-extent label)) + (send dc draw-text label + (+ dx (+ border-inset circle-spacer button-label-inset)) + (+ dy (- (/ h 2) (/ th 2))) + #t)) + (send dc set-pen "black" 1 'transparent) - (send dc set-brush (if grabbed? grabbed-fg-color triangle-color) 'solid) - (let ([x (- w triangle-width circle-spacer border-inset)] - [y (- (/ h 2) (/ triangle-height 2))]) - (define ul-x (+ x 1)) - (define ul-y (+ y 5 1/2)) - (define ur-x (+ x (- triangle-width 1))) - (define bm-x (/ (+ ul-x ur-x) 2)) - (define bm-y (+ y 10 1/2)) - (send dc draw-polygon - (list (cons (+ dx ul-x) (+ dy ul-y)) - (cons (+ dx ur-x) (+ dy ul-y)) - (cons (+ dx bm-x) (+ dy bm-y))))) - + (send dc set-brush (if grabbed? (get-grabbed-fg-color) (get-triangle-color)) 'solid) + (define x (- w triangle-width circle-spacer border-inset)) + (define y (- (/ h 2) (/ triangle-height 2))) + (define ul-x (+ x 1)) + (define ul-y (+ y 5 1/2)) + (define ur-x (+ x (- triangle-width 1))) + (define bm-x (/ (+ ul-x ur-x) 2)) + (define bm-y (+ y 10 1/2)) + (send dc draw-polygon + (list (cons (+ dx ul-x) (+ dy ul-y)) + (cons (+ dx ur-x) (+ dy ul-y)) + (cons (+ dx bm-x) (+ dy bm-y)))) + (void)) diff -Nru racket-7.2+ppa2/share/pkgs/gui-lib/mrlib/private/panel-wob.rkt racket-7.3+ppa1/share/pkgs/gui-lib/mrlib/private/panel-wob.rkt --- racket-7.2+ppa2/share/pkgs/gui-lib/mrlib/private/panel-wob.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/gui-lib/mrlib/private/panel-wob.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,19 @@ +#lang racket/base +(require racket/class racket/gui/base) +(provide white-on-black-panel-scheme?) + +(define (luminance c) + ;; from https://en.wikipedia.org/wiki/Relative_luminance + (define r (/ (send c red) 255)) + (define g (/ (send c green) 255)) + (define b (/ (send c blue) 255)) + (+ (* .2126 r) + (* .7152 g) + (* .0722 b))) + +(define (white-on-black-panel-scheme?) + ;; if the background and foreground are the same + ;; color, probably something has gone wrong; + ;; in that case we want to return #f. + (< (luminance (get-label-background-color)) + (luminance (get-label-foreground-color)))) diff -Nru racket-7.2+ppa2/share/pkgs/gui-lib/mrlib/switchable-button.rkt racket-7.3+ppa1/share/pkgs/gui-lib/mrlib/switchable-button.rkt --- racket-7.2+ppa2/share/pkgs/gui-lib/mrlib/switchable-button.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/gui-lib/mrlib/switchable-button.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1,6 +1,7 @@ #lang racket/base (require racket/gui/base - racket/class) + racket/class + "private/panel-wob.rkt") (provide switchable-button%) (define gap 4) ;; space between the text and the icon @@ -8,9 +9,9 @@ (define w-circle-space 6) (define h-circle-space 6) -;; extra space outside the bitmap, +;; extra space outside the bitmap, ;; but inside the mouse highlighting (on the right) -(define rhs-pad 2) +(define rhs-pad 2) (define half-gray (make-object color% 127 127 127)) (define one-fifth-gray (make-object color% 200 200 200)) @@ -18,34 +19,34 @@ (define yellow-message% (class canvas% (init-field label) - + (define/override (on-paint) - (let ([dc (get-dc)]) - (let ([pen (send dc get-pen)] - [brush (send dc get-brush)] - [font (send dc get-font)] - [yellow (make-object color% 255 255 200)]) - - (send dc set-pen yellow 1 'transparent) - (send dc set-brush yellow 'solid) - (let-values ([(cw ch) (get-client-size)]) - (send dc draw-rectangle 0 0 cw ch) - - (send dc set-font small-control-font) - - (let-values ([(tw th _1 _2) (send dc get-text-extent label)]) - (send dc draw-text - label - (- (/ cw 2) (/ tw 2)) - (- (/ ch 2) (/ th 2))))) - - (send dc set-pen pen) - (send dc set-brush brush) - (send dc set-font font)))) - + (define dc (get-dc)) + (define pen (send dc get-pen)) + (define brush (send dc get-brush)) + (define font (send dc get-font)) + (define yellow (make-object color% 255 255 200)) + + (send dc set-pen yellow 1 'transparent) + (send dc set-brush yellow 'solid) + (define-values (cw ch) (get-client-size)) + (send dc draw-rectangle 0 0 cw ch) + + (send dc set-font small-control-font) + + (define-values (tw th _1 _2) (send dc get-text-extent label)) + (send dc draw-text + label + (- (/ cw 2) (/ tw 2)) + (- (/ ch 2) (/ th 2))) + + (send dc set-pen pen) + (send dc set-brush brush) + (send dc set-font font)) + (define/override (on-event evt) (send (get-top-level-window) show #f)) - + (inherit stretchable-width stretchable-height min-width min-height get-client-size get-dc @@ -57,40 +58,40 @@ (define switchable-button% (class canvas% - (init-field label + (init-field label bitmap callback [alternate-bitmap bitmap] [vertical-tight? #f] [min-width-includes-label? #f]) - + (define/public (get-button-label) label) (define/override (set-label l) (set! label l) (update-sizes) (refresh)) - + (when (and (is-a? label bitmap%) (not (send label ok?))) (error 'switchable-button% "label bitmap is not ok?")) - + (define/override (get-label) label) - + (define disable-bitmap (make-dull-mask bitmap)) - + (define alternate-disable-bitmap (if (eq? bitmap alternate-bitmap) disable-bitmap (make-dull-mask alternate-bitmap))) - + (inherit get-dc min-width min-height get-client-size refresh client->screen) - + (define down? #f) (define in? #f) (define disabled? #f) - (define with-label? (string? label)) - + (define has-label? (string? label)) + (define/override (enable e?) (unless (equal? disabled? (not e?)) (set! disabled? (not e?)) @@ -106,7 +107,7 @@ (update-float #f) (refresh)) (super on-superwindow-show show?)) - + (define/override (on-event evt) (cond [(send evt button-down? 'left) @@ -138,23 +139,23 @@ (define/public (command) (callback this) (void)) - + (define float-window #f) (inherit get-width get-height) - (define timer (new timer% - [just-once? #t] + (define timer (new timer% + [just-once? #t] [notify-callback (λ () - (unless with-label? + (unless has-label? (unless (equal? (send float-window is-shown?) in?) (send float-window show in?))) (set! timer-running? #f))])) (define timer-running? #f) - + (define/private (update-float new-value?) (when label (cond - [with-label? + [has-label? (when float-window (send float-window show #f))] [else @@ -163,145 +164,154 @@ (cond [new-value? (unless float-window - (set! float-window (new frame% + (set! float-window (new frame% [label ""] [style '(no-caption no-resize-border float)] [stretchable-width #f] [stretchable-height #f])) (new yellow-message% [parent float-window] [label (or label "")])) - + (send float-window reflow-container) - + ;; position the floating window - (let-values ([(dw dh) (get-display-size)] - [(x y) (client->screen (floor (get-width)) - (floor - (- (/ (get-height) 2) - (/ (send float-window get-height) 2))))] - [(dx dy) (get-display-left-top-inset)]) - (let ([rhs-x (- x dx)] - [rhs-y (- y dy)]) - (cond - [(< (+ rhs-x (send float-window get-width)) dw) - (send float-window move rhs-x rhs-y)] - [else - (send float-window move - (- rhs-x (send float-window get-width) (get-width)) - rhs-y)]))) + (define-values (dw dh) (get-display-size)) + (define-values (x y) (client->screen (floor (get-width)) + (floor + (- (/ (get-height) 2) + (/ (send float-window get-height) 2))))) + (define-values (dx dy) (get-display-left-top-inset)) + (define rhs-x (- x dx)) + (define rhs-y (- y dy)) + (cond + [(< (+ rhs-x (send float-window get-width)) dw) + (send float-window move rhs-x rhs-y)] + [else + (send float-window move + (- rhs-x (send float-window get-width) (get-width)) + rhs-y)]) (unless timer-running? (set! timer-running? #t) (send timer start 500 #t))] [else (when float-window (send float-window show #f))]))]))) - + (define/private (update-in evt) - (let-values ([(cw ch) (get-client-size)]) - (let ([new-in? - (and (<= 0 (send evt get-x) cw) - (<= 0 (send evt get-y) ch))]) - (unless (equal? new-in? in?) - (set! in? new-in?) - (refresh)) - (update-float new-in?)))) - + (define-values (cw ch) (get-client-size)) + (define new-in? + (and (<= 0 (send evt get-x) cw) + (<= 0 (send evt get-y) ch))) + (unless (equal? new-in? in?) + (set! in? new-in?) + (refresh)) + (update-float new-in?)) + (define/override (on-paint) - (let ([dc (get-dc)]) - (let-values ([(cw ch) (get-client-size)]) - (let ([alpha (send dc get-alpha)] - [pen (send dc get-pen)] - [brush (send dc get-brush)]) - - ;; Draw background. Use alpha blending if it can work, - ;; otherwise fall back to a suitable color. - (let ([color (cond - [disabled? #f] - [in? (if (eq? (send dc get-smoothing) 'aligned) - (if down? 0.5 0.2) - (if down? - half-gray - one-fifth-gray))] - [else #f])]) - (when color - (send dc set-pen "black" 1 'transparent) - (send dc set-brush (if (number? color) "black" color) 'solid) - (when (number? color) - (send dc set-alpha color)) - (send dc draw-rounded-rectangle - margin - margin - (max 0 (- cw margin margin)) - (max 0 (- ch margin margin))) - (when (number? color) - (send dc set-alpha alpha)))) - - (send dc set-font normal-control-font) - - (when disabled? - (send dc set-alpha .5)) - - (cond - [with-label? - (cond - [(<= cw (get-small-width)) - (draw-the-bitmap (- (/ cw 2) (/ (send bitmap get-width) 2)) - (- (/ ch 2) (/ (send bitmap get-height) 2)))] - [else - (define-values (tw th _1 _2) (send dc get-text-extent label)) - (define text-start (+ (/ cw 2) - (- (/ tw 2)) - (- (/ (send bitmap get-width) 2)) - (- rhs-pad))) - (send dc draw-text label text-start (- (/ ch 2) (/ th 2))) - (draw-the-bitmap (+ text-start tw gap) - (- (/ ch 2) (/ (send bitmap get-height) 2)))])] - [else - (draw-the-bitmap - (- (/ cw 2) - (/ (send (if with-label? bitmap alternate-bitmap) get-width) - 2)) - (- (/ ch 2) - (/ (send (if with-label? bitmap alternate-bitmap) get-height) - 2)))]) - - (send dc set-pen pen) - (send dc set-alpha alpha) - (send dc set-brush brush))))) - + (define dc (get-dc)) + (define-values (cw ch) (get-client-size)) + (define alpha (send dc get-alpha)) + (define pen (send dc get-pen)) + (define text-foreground (send dc get-text-foreground)) + (define brush (send dc get-brush)) + + ;; Draw background. Use alpha blending if it can work, + ;; otherwise fall back to a suitable color. + (define down-same-as-black-on-white? + (equal? down? + (not (white-on-black-panel-scheme?)))) + (define color + (cond + [disabled? #f] + [in? (if (equal? (send dc get-smoothing) 'aligned) + (if down-same-as-black-on-white? 0.5 0.2) + (if down-same-as-black-on-white? + half-gray + one-fifth-gray))] + [else #f])) + (when color + (send dc set-pen "black" 1 'transparent) + (send dc set-brush (if (number? color) + (get-label-foreground-color) + color) 'solid) + (when (number? color) + (send dc set-alpha color)) + (send dc draw-rounded-rectangle + margin + margin + (max 0 (- cw margin margin)) + (max 0 (- ch margin margin))) + (when (number? color) + (send dc set-alpha alpha))) + + (send dc set-font normal-control-font) + + (when disabled? + (send dc set-alpha .5)) + + (cond + [has-label? + (cond + [(<= cw (get-small-width)) + (draw-the-bitmap (- (/ cw 2) (/ (send bitmap get-width) 2)) + (- (/ ch 2) (/ (send bitmap get-height) 2)))] + [else + (define-values (tw th _1 _2) (send dc get-text-extent label)) + (define text-start (+ (/ cw 2) + (- (/ tw 2)) + (- (/ (send bitmap get-width) 2)) + (- rhs-pad))) + (send dc set-text-foreground (get-label-foreground-color)) + (send dc draw-text label text-start (- (/ ch 2) (/ th 2))) + (draw-the-bitmap (+ text-start tw gap) + (- (/ ch 2) (/ (send bitmap get-height) 2)))])] + [else + (draw-the-bitmap + (- (/ cw 2) + (/ (send (if has-label? bitmap alternate-bitmap) get-width) + 2)) + (- (/ ch 2) + (/ (send (if has-label? bitmap alternate-bitmap) get-height) + 2)))]) + + (send dc set-pen pen) + (send dc set-alpha alpha) + (send dc set-brush brush) + (send dc set-text-foreground text-foreground)) + (define/private (draw-the-bitmap x y) - (let ([bm (if with-label? bitmap alternate-bitmap)]) - (send (get-dc) - draw-bitmap - bm - x y - 'solid - (send the-color-database find-color "black") - (if disabled? - (if with-label? disable-bitmap alternate-disable-bitmap) - (send bm get-loaded-mask))))) - + (define bm (if has-label? bitmap alternate-bitmap)) + (send (get-dc) + draw-bitmap + bm + x y + 'solid + (send the-color-database find-color "black") + (if disabled? + (if has-label? disable-bitmap alternate-disable-bitmap) + (send bm get-loaded-mask)))) + (define/public (set-label-visible in-h?) (define h? (and in-h? #t)) - (unless (equal? with-label? h?) - (set! with-label? h?) + (unless (equal? has-label? h?) + (set! has-label? h?) (update-sizes) - (update-float (and with-label? in?)) + (update-float (and has-label? in?)) (refresh))) - (define/public (get-label-visible) with-label?) - + (define/public (get-label-visible) has-label?) + (define/private (update-sizes) (define dc (get-dc)) (define-values (tw th _1 _2) (send dc get-text-extent label normal-control-font)) - (define h - (inexact->exact + (define h + (inexact->exact (floor (+ (max th (send alternate-bitmap get-height) (send bitmap get-height)) - h-circle-space margin margin + h-circle-space margin margin (if vertical-tight? -6 0))))) (cond - [with-label? + [has-label? (cond [min-width-includes-label? (min-width (get-large-width))] @@ -311,7 +321,7 @@ [else (min-width (get-without-label-small-width)) (min-height h)])) - + (define/public (get-large-width) (define dc (get-dc)) (define-values (tw th _1 _2) (send dc get-text-extent label normal-control-font)) @@ -321,7 +331,7 @@ w-circle-space margin margin)))) - + (define/public (get-without-label-small-width) (inexact->exact (floor @@ -329,7 +339,7 @@ w-circle-space margin margin)))) - + (define/public (get-small-width) (inexact->exact (floor @@ -337,10 +347,10 @@ w-circle-space margin margin)))) - + (super-new [style '(transparent no-focus)]) (send (get-dc) set-smoothing 'aligned) - + (inherit stretchable-width stretchable-height) (stretchable-width #f) (stretchable-height #f) @@ -348,55 +358,57 @@ (update-sizes))) (define (make-dull-mask bitmap) - (let ([alpha-bm (send bitmap get-loaded-mask)]) - (and alpha-bm - (let* ([w (send alpha-bm get-width)] - [h (send alpha-bm get-height)] - [disable-bm (make-object bitmap% w h)] - [pixels (make-bytes (* 4 w h))] - [bdc (make-object bitmap-dc% alpha-bm)]) - (send bdc get-argb-pixels 0 0 w h pixels) - (let loop ([i 0]) - (when (< i (* 4 w h)) - (bytes-set! pixels i (- 255 (quotient (- 255 (bytes-ref pixels i)) 2))) - (loop (+ i 1)))) - (send bdc set-bitmap disable-bm) - (send bdc set-argb-pixels 0 0 w h pixels) - (send bdc set-bitmap #f) - disable-bm)))) + (define alpha-bm (send bitmap get-loaded-mask)) + (cond + [alpha-bm + (define w (send alpha-bm get-width)) + (define h (send alpha-bm get-height)) + (define disable-bm (make-object bitmap% w h)) + (define pixels (make-bytes (* 4 w h))) + (define bdc (make-object bitmap-dc% alpha-bm)) + (send bdc get-argb-pixels 0 0 w h pixels) + (let loop ([i 0]) + (when (< i (* 4 w h)) + (bytes-set! pixels i (- 255 (quotient (- 255 (bytes-ref pixels i)) 2))) + (loop (+ i 1)))) + (send bdc set-bitmap disable-bm) + (send bdc set-argb-pixels 0 0 w h pixels) + (send bdc set-bitmap #f) + disable-bm] + [else #f])) #; (begin (define f (new frame% [label ""])) (define vp (new vertical-pane% [parent f])) (define p (new horizontal-panel% [parent vp] [alignment '(right top)])) - + (define label "Run") (define bitmap (make-object bitmap% (build-path (collection-path "icons") "run.png") 'png/mask)) (define foot (make-object bitmap% (build-path (collection-path "icons") "foot.png") 'png/mask)) - (define foot-up + (define foot-up (make-object bitmap% (build-path (collection-path "icons") "foot-up.png") 'png/mask)) - + (define b1 (new switchable-button% [parent p] [label label] [bitmap bitmap] [callback void])) (define b2 (new switchable-button% [parent p] [label label] [bitmap bitmap] [callback void])) (define b3 (new switchable-button% [parent p] [label "Step"] [bitmap foot] - [alternate-bitmap foot-up] + [alternate-bitmap foot-up] [callback void])) (define sb (new button% [parent p] [stretchable-width #t] [label "b"])) (define swap-button - (new button% - [parent f] + (new button% + [parent f] [label "swap"] [callback - (let ([state #t]) - (λ (a b) - (set! state (not state)) - (send b1 set-label-visible state) - (send b2 set-label-visible state) - (send b3 set-label-visible state)))])) + (define state #t) + (λ (a b) + (set! state (not state)) + (send b1 set-label-visible state) + (send b2 set-label-visible state) + (send b3 set-label-visible state))])) (define disable-button - (new button% - [parent f] + (new button% + [parent f] [label "disable"] [callback (λ (a b) diff -Nru racket-7.2+ppa2/share/pkgs/gui-lib/scribble/private/indentation.rkt racket-7.3+ppa1/share/pkgs/gui-lib/scribble/private/indentation.rkt --- racket-7.2+ppa2/share/pkgs/gui-lib/scribble/private/indentation.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/gui-lib/scribble/private/indentation.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -239,6 +239,10 @@ (and end-sexp-boundary (empty-para? txt end-sexp-para))) ;; this shouldn't be possible (I think?) but be conservative in case it is (values #f #f)] + [(empty-para? txt (send txt position-paragraph pos)) + ;; if we are starting on the blank space + ;; between paragraphs then don't do anything + (values #f #f)] [else (define start-position (let loop ([para (send txt position-paragraph pos)]) @@ -838,6 +842,15 @@ "sss ttt uuu vvv}]\n") (check-equal? (call-with-values (λ () (find-paragraph-boundaries t 38)) list) (list 36 73))) + + (let ([t (new racket:text%)]) + (define str "#lang scribble/base @x{x\n\n}") + (define x 25) + (send t insert str) + (send t freeze-colorer) + (send t set-position x x) + (check-equal? (call-with-values (λ () (find-paragraph-boundaries t x)) list) + (list #f #f))) (let ([t (new racket:text%)]) diff -Nru racket-7.2+ppa2/share/pkgs/gui-pkg-manager-lib/info.rkt racket-7.3+ppa1/share/pkgs/gui-pkg-manager-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/gui-pkg-manager-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/gui-pkg-manager-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/htdp/info.rkt racket-7.3+ppa1/share/pkgs/htdp/info.rkt --- racket-7.2+ppa2/share/pkgs/htdp/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/htdp/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/htdp-doc/info.rkt racket-7.3+ppa1/share/pkgs/htdp-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/htdp-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/htdp-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (define collection (quote multi)) (define deps (quote ("base" "scribble-lib" "at-exp-lib" "draw-lib" ("gui-lib" #:version "1.37") "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.3"))) (define collection (quote multi)) (define deps (quote ("base" "scribble-lib" "at-exp-lib" "draw-lib" ("gui-lib" #:version "1.37") "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-7.2+ppa2/share/pkgs/htdp-doc/teachpack/2htdp/scribblings/image.scrbl racket-7.3+ppa1/share/pkgs/htdp-doc/teachpack/2htdp/scribblings/image.scrbl --- racket-7.2+ppa2/share/pkgs/htdp-doc/teachpack/2htdp/scribblings/image.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/htdp-doc/teachpack/2htdp/scribblings/image.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -1,7 +1,6 @@ #lang scribble/doc -@(require (for-label (only-in racket/contract and/c or/c any/c not/c listof - >=/c <=/c) +@(require (for-label racket/contract 2htdp/image (except-in lang/htdp-beginner posn make-posn posn? posn-x posn-y image?) lang/posn @@ -1801,10 +1800,10 @@ (list @colorName[clr-bytes clr-bytes (send clr red) (send clr green) (send clr blue)])))) } -@defstruct[color ([red (and/c natural-number/c (<=/c 255))] - [green (and/c natural-number/c (<=/c 255))] - [blue (and/c natural-number/c (<=/c 255))] - [alpha (and/c natural-number/c (<=/c 255))])]{ +@defstruct[color ([red (integer-in 0 255)] + [green (integer-in 0 255)] + [blue (integer-in 0 255)] + [alpha (integer-in 0 255)])]{ The @racket[color] struct defines a color with @racket[red], @racket[green], @racket[blue], and @racket[alpha] components that range from @racket[0] to @racket[255]. diff -Nru racket-7.2+ppa2/share/pkgs/htdp-lib/info.rkt racket-7.3+ppa1/share/pkgs/htdp-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/htdp-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/htdp-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.20") "typed-racket-lib" "typed-racket-more" "web-server-lib" "wxme-lib" ("gui-lib" #:version "1.36") "deinprogramm-signature" "pict-lib"))) (define build-deps (quote ("racket-index" "at-exp-lib" ("rackunit-lib" #:version "1.10")))) (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.3"))) (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.20") "typed-racket-lib" "typed-racket-more" "web-server-lib" "wxme-lib" ("gui-lib" #:version "1.36") "deinprogramm-signature" "pict-lib"))) (define build-deps (quote ("racket-index" "at-exp-lib" ("rackunit-lib" #:version "1.10")))) (define pkg-desc "implementation (no documentation) part of \"htdp\"") (define pkg-authors (quote (matthias mflatt robby))) (define version "1.7"))) diff -Nru racket-7.2+ppa2/share/pkgs/htdp-lib/lang/private/beginner-funs.rkt racket-7.3+ppa1/share/pkgs/htdp-lib/lang/private/beginner-funs.rkt --- racket-7.2+ppa2/share/pkgs/htdp-lib/lang/private/beginner-funs.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/htdp-lib/lang/private/beginner-funs.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -158,8 +158,8 @@ @interaction[#:eval (bsl) (min 3 2 8 7 2 9 0)] } @defproc[(quotient [x integer][y integer]) integer]{ - Divides the second integer---also called divisor---into the first---known as - dividend---to obtain the @index[(list "divide" "quotient")]{quotient}. + Divides the first integer---also called dividend---by the second---known as + divisor---to obtain the @index[(list "divide" "quotient")]{quotient}. @interaction[#:eval (bsl) (quotient 9 2) (quotient 3 4)] } @defproc[(remainder [x integer][y integer]) integer]{ @@ -831,7 +831,7 @@ Copies a string. @;why is it included? @interaction[#:eval (bsl) (string-copy "hello")] } - @defproc[(string-append [s string] ...) string]{ + @defproc[([beginner-string-append string-append] [s string] [t string] [z string] ...) string]{ Concatenates the characters of several strings. @interaction[#:eval (bsl) (string-append "hello" " " "world" " " "good bye")] } @@ -845,46 +845,46 @@ @interaction[#:eval (bsl) (string-downcase "CAT") (string-downcase "cAt")] } - @defproc[(string=? [s string][t string][x string] ...) boolean?]{ + @defproc[([beginner-string=? string=?] [s string][t string][x string] ...) boolean?]{ Determines whether all strings are equal, character for character. @interaction[#:eval (bsl) (string=? "hello" "world") (string=? "bye" "bye")] } - @defproc[(string? [s string][t string][x string] ...) boolean?]{ + @defproc[([beginner-string>? string>?] [s string][t string][x string] ...) boolean?]{ Determines whether the strings are ordered in a lexicographically strictly decreasing manner. @interaction[#:eval (bsl) (string>? "zoo" "world" "hello")] } - @defproc[(string<=? [s string][t string][x string] ...) boolean?]{ + @defproc[([beginner-string<=? string<=?] [s string][t string][x string] ...) boolean?]{ Determines whether the strings are ordered in a lexicographically increasing manner. @interaction[#:eval (bsl) (string<=? "hello" "hello" "world" "zoo")] } - @defproc[(string>=? [s string][t string][x string] ...) boolean?]{ + @defproc[([beginner-string>=? string>=?] [s string][t string][x string] ...) boolean?]{ Determines whether the strings are ordered in a lexicographically decreasing manner. @interaction[#:eval (bsl) (string>=? "zoo" "zoo" "world" "hello")] } - @defproc[(string-ci=? [s string][t string][x string] ...) boolean?]{ + @defproc[([beginner-string-ci=? string-ci=?] [s string][t string][x string] ...) boolean?]{ Determines whether all strings are equal, character for character, regardless of case. @interaction[#:eval (bsl) (string-ci=? "hello" "HellO")] } - @defproc[(string-ci? [s string][t string][x string] ...) boolean?]{ + @defproc[([beginner-string-ci>? string-ci>?] [s string][t string][x string] ...) boolean?]{ Determines whether the strings are ordered in a lexicographically strictly decreasing and case-insensitive manner. @interaction[#:eval (bsl) (string-ci>? "zoo" "WORLD" "hello")] } - @defproc[(string-ci<=? [s string][t string][x string] ...) boolean?]{ + @defproc[([beginner-string-ci<=? string-ci<=?] [s string][t string][x string] ...) boolean?]{ Determines whether the strings are ordered in a lexicographically increasing and case-insensitive manner. @interaction[#:eval (bsl) (string-ci<=? "hello" "WORLD" "zoo")] } - @defproc[(string-ci>=? [s string][t string][x string] ...) boolean?]{ + @defproc[([beginner-string-ci>=? string-ci>=?] [s string][t string][x string] ...) boolean?]{ Determines whether the strings are ordered in a lexicographically decreasing and case-insensitive manner. @interaction[#:eval (bsl) (string-ci>? "zoo" "WORLD" "hello")] diff -Nru racket-7.2+ppa2/share/pkgs/htdp-lib/lang/private/intermediate-funs.rkt racket-7.3+ppa1/share/pkgs/htdp-lib/lang/private/intermediate-funs.rkt --- racket-7.2+ppa2/share/pkgs/htdp-lib/lang/private/intermediate-funs.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/htdp-lib/lang/private/intermediate-funs.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -11,202 +11,263 @@ (require "provide-and-scribble.rkt") (provide-and-scribble - procedures + procedures - (begin - (require scribble/manual scribble/eval "sl-eval.rkt") - (define (isl) - (define *bsl - (isl+-eval - [(define i 3) - (define a-list '(0 1 2 3 4 5 6 7 8 9)) - (define threshold 3)])) - (set! isl (lambda () *bsl)) - *bsl)) - - (all-from-except beginner: - (submod lang/private/beginner-funs without-wrapper) - procedures + * / append) + (begin + (require scribble/manual scribble/eval "sl-eval.rkt") + (define (isl) + (define *bsl + (isl+-eval + [(define i 3) + (define a-list '(0 1 2 3 4 5 6 7 8 9)) + (define threshold 3)])) + (set! isl (lambda () *bsl)) + *bsl)) + + (all-from-except beginner: + (submod lang/private/beginner-funs without-wrapper) + procedures + * / append + string-append + string=? + string? + string<=? + string>=? + string-ci=? + string-ci? + string-ci<=? + string-ci>=?) - ("Numbers (relaxed conditions)" - @defproc[(+ [x number] ...) number]{ - Adds all given numbers. - In ISL and up: @racket[+] works when applied to only one number or none. - @interaction[#:eval (isl) (+ 2/3 1/16) (+ 3 2 5 8) (+ 1) (+)] - } - @defproc[(* [x number] ...) number]{ - Multiplies all given numbers. - In ISL and up: @racket[*] works when applied to only one number or none. - @interaction[#:eval (isl) (* 5 3) (* 5 3 2) (* 2) (*)] - } - @defproc[(/ [x number] [y number] ...) number]{ - Divides the first by all remaining numbers. - In ISL and up: @racket[/] computes the inverse when applied to one number. - @interaction[#:eval (isl) (/ 12 2) (/ 12 2 3) (/ 3)] - } - ) + ("Numbers (relaxed conditions)" + @defproc[(+ [x number] ...) number]{ + Adds all given numbers. + In ISL and up: @racket[+] works when applied to only one number or none. + @interaction[#:eval (isl) (+ 2/3 1/16) (+ 3 2 5 8) (+ 1) (+)] +} + @defproc[(* [x number] ...) number]{ + Multiplies all given numbers. + In ISL and up: @racket[*] works when applied to only one number or none. + @interaction[#:eval (isl) (* 5 3) (* 5 3 2) (* 2) (*)] +} + @defproc[(/ [x number] [y number] ...) number]{ + Divides the first by all remaining numbers. + In ISL and up: @racket[/] computes the inverse when applied to one number. + @interaction[#:eval (isl) (/ 12 2) (/ 12 2 3) (/ 3)] +} + ) + + ("String (relaxed conditions)" + @defproc[(string-append [s string] ...) string]{ + Concatenates the characters of several strings. + @interaction[#:eval (isl) (string-append "hello" " " "world" " " "good bye")]} + + @defproc[(string=? [s string][t string][x string] ...) boolean?]{ + Determines whether all strings are equal, character for character. + @interaction[#:eval (isl) (string=? "hello" "world") (string=? "bye" "bye")]} + + @defproc[(string? [s string][t string][x string] ...) boolean?]{ + Determines whether the strings are ordered in a lexicographically strictly decreasing manner. + @interaction[#:eval (isl) (string>? "zoo" "world" "hello")]} + + @defproc[(string<=? [s string][t string][x string] ...) boolean?]{ + Determines whether the strings are ordered in a lexicographically increasing manner. + @interaction[#:eval (isl) (string<=? "hello" "hello" "world" "zoo")]} + + @defproc[(string>=? [s string][t string][x string] ...) boolean?]{ + Determines whether the strings are ordered in a lexicographically decreasing manner. + @interaction[#:eval (isl) (string>=? "zoo" "zoo" "world" "hello")]} + + @defproc[(string-ci=? [s string][t string][x string] ...) boolean?]{ + Determines whether all strings are equal, character for character, regardless of case. + @interaction[#:eval (isl) (string-ci=? "hello" "HellO")]} + + @defproc[(string-ci? [s string][t string][x string] ...) boolean?]{ + Determines whether the strings are ordered in a lexicographically + strictly decreasing and case-insensitive manner. + @interaction[#:eval (isl) (string-ci>? "zoo" "WORLD" "hello")]} + + @defproc[(string-ci<=? [s string][t string][x string] ...) boolean?]{ + Determines whether the strings are ordered in a lexicographically + increasing and case-insensitive manner. + @interaction[#:eval (isl) (string-ci<=? "hello" "WORLD" "zoo")]} + + @defproc[(string-ci>=? [s string][t string][x string] ...) boolean?]{ + Determines whether the strings are ordered in a lexicographically + decreasing and case-insensitive manner. + @interaction[#:eval (isl) (string-ci>? "zoo" "WORLD" "hello")]} + ) - ("Posn" - @defproc[(posn) signature]{Signature for posns.}) + ("Posn" + @defproc[(posn) signature]{Signature for posns.}) - ("Lists" - @defproc[((intermediate-append append) [l (listof any)] ...) (listof any)]{ - Creates a single list from several, by concatenation of the items. - In ISL and up: @racket[append] also works when applied to one list or none. - @interaction[#:eval (isl) - (append (cons 1 (cons 2 '())) (cons "a" (cons "b" '()))) - (append)]} -) + ("Lists" + @defproc[((intermediate-append append) [l (listof any)] ...) (listof any)]{ + Creates a single list from several, by concatenation of the items. + In ISL and up: @racket[append] also works when applied to one list or none. + @interaction[#:eval (isl) + (append (cons 1 (cons 2 '())) (cons "a" (cons "b" '()))) + (append)]} + ) - ("Higher-Order Functions" - @defproc[((intermediate-map map) [f (X ... -> Z)] [l (listof X)] ...) (listof Z)]{ - Constructs a new list by applying a function to each item on one or - more existing lists: - @codeblock{(map f (list x-1 ... x-n)) = (list (f x-1) ... (f x-n))} - @codeblock{(map f (list x-1 ... x-n) (list y-1 ... y-n)) = (list (f x-1 y-1) ... (f x-n y-n))} - @interaction[#:eval (isl) - (map add1 '(3 -4.01 2/5)) - (map (lambda (x) (list 'my-list (+ x 1))) '(3 -4.01 2/5)) - (map (lambda (x y) (+ x (* x y))) '(3 -4 2/5) '(1 2 3))] - } - @defproc[(for-each [f (any ... -> any)] [l (listof any)] ...) void?]{ - Applies a function to each item on one or more lists for effect only: - @codeblock{(for-each f (list x-1 ... x-n)) = (begin (f x-1) ... (f x-n))} - @interaction[#:eval (asl-eval) - (for-each (lambda (x) (begin (display x) (newline))) '(1 2 3)) - ] - } - @defproc[((intermediate-filter filter) [p? (X -> boolean)] [l (listof X)]) (listof X)]{ - Constructs a list from all those items on a list for which the predicate holds. - @interaction[#:eval (isl) - (filter odd? '(0 1 2 3 4 5 6 7 8 9)) - threshold - (filter (lambda (x) (>= x threshold)) '(0 1 2 3 4 5 6 7 8 9)) - ] - } - @defproc[((intermediate-foldr foldr) [f (X ... Y -> Y)] [base Y] [l (listof X)] ...) Y]{ - @codeblock{(foldr f base (list x-1 ... x-n)) = (f x-1 ... (f x-n base))} - @codeblock{(foldr f base (list x-1 ... x-n) (list y-1 ... y-n)) - = (f x-1 y-1 ... (f x-n y-n base))} - @interaction[#:eval (isl) - (foldr + 0 '(0 1 2 3 4 5 6 7 8 9)) - a-list - (foldr (lambda (x r) (if (> x threshold) (cons (* 2 x) r) r)) '() a-list) - (foldr (lambda (x y r) (+ x y r)) 0 '(1 2 3) '(10 11 12)) - ] - } - @defproc[((intermediate-foldl foldl) [f (X ... Y -> Y)] [base Y] [l (listof X)] ...) Y]{ - @codeblock{(foldl f base (list x-1 ... x-n)) = (f x-n ... (f x-1 base))} - @codeblock{(foldl f base (list x-1 ... x-n) (list x-1 ... x-n)) - = (f x-n y-n ... (f x-1 y-1 base))} - @interaction[#:eval (isl) - (foldl + 0 '(0 1 2 3 4 5 6 7 8 9)) - a-list - (foldl (lambda (x r) (if (> x threshold) (cons (* 2 x) r) r)) '() a-list) - (foldl (lambda (x y r) (+ x y r)) 0 '(1 2 3) '(10 11 12)) - ] - } - @defproc[(build-list [n nat] [f (nat -> X)]) (listof X)]{ - Constructs a list by applying @racket[f] to the numbers between @racket[0] and @racket[(- n 1)]: - @codeblock{(build-list n f) = (list (f 0) ... (f (- n 1)))} - @interaction[#:eval (isl) - (build-list 22 add1) - i - (build-list 3 (lambda (j) (+ j i))) - (build-list 5 - (lambda (i) - (build-list 5 - (lambda (j) - (if (= i j) 1 0))))) - ] - } - @defproc[((intermediate-build-string build-string) [n nat] [f (nat -> char)]) string]{ - Constructs a string by applying @racket[f] to the numbers between @racket[0] and + ("Higher-Order Functions" + @defproc[((intermediate-map map) [f (X ... -> Z)] [l (listof X)] ...) (listof Z)]{ + Constructs a new list by applying a function to each item on one or + more existing lists: + @codeblock{(map f (list x-1 ... x-n)) = (list (f x-1) ... (f x-n))} + @codeblock{(map f (list x-1 ... x-n) (list y-1 ... y-n)) = (list (f x-1 y-1) ... (f x-n y-n))} + @interaction[#:eval (isl) + (map add1 '(3 -4.01 2/5)) + (map (lambda (x) (list 'my-list (+ x 1))) '(3 -4.01 2/5)) + (map (lambda (x y) (+ x (* x y))) '(3 -4 2/5) '(1 2 3))] +} + @defproc[(for-each [f (any ... -> any)] [l (listof any)] ...) void?]{ + Applies a function to each item on one or more lists for effect only: + @codeblock{(for-each f (list x-1 ... x-n)) = (begin (f x-1) ... (f x-n))} + @interaction[#:eval (asl-eval) + (for-each (lambda (x) (begin (display x) (newline))) '(1 2 3)) + ] +} + @defproc[((intermediate-filter filter) [p? (X -> boolean)] [l (listof X)]) (listof X)]{ + Constructs a list from all those items on a list for which the predicate holds. + @interaction[#:eval (isl) + (filter odd? '(0 1 2 3 4 5 6 7 8 9)) + threshold + (filter (lambda (x) (>= x threshold)) '(0 1 2 3 4 5 6 7 8 9)) + ] +} + @defproc[((intermediate-foldr foldr) [f (X ... Y -> Y)] [base Y] [l (listof X)] ...) Y]{ + @codeblock{(foldr f base (list x-1 ... x-n)) = (f x-1 ... (f x-n base))} + @codeblock{(foldr f base (list x-1 ... x-n) (list y-1 ... y-n)) + = (f x-1 y-1 ... (f x-n y-n base))} + @interaction[#:eval (isl) + (foldr + 0 '(0 1 2 3 4 5 6 7 8 9)) + a-list + (foldr (lambda (x r) (if (> x threshold) (cons (* 2 x) r) r)) '() a-list) + (foldr (lambda (x y r) (+ x y r)) 0 '(1 2 3) '(10 11 12)) + ] +} + @defproc[((intermediate-foldl foldl) [f (X ... Y -> Y)] [base Y] [l (listof X)] ...) Y]{ + @codeblock{(foldl f base (list x-1 ... x-n)) = (f x-n ... (f x-1 base))} + @codeblock{(foldl f base (list x-1 ... x-n) (list x-1 ... x-n)) + = (f x-n y-n ... (f x-1 y-1 base))} + @interaction[#:eval (isl) + (foldl + 0 '(0 1 2 3 4 5 6 7 8 9)) + a-list + (foldl (lambda (x r) (if (> x threshold) (cons (* 2 x) r) r)) '() a-list) + (foldl (lambda (x y r) (+ x y r)) 0 '(1 2 3) '(10 11 12)) + ] +} + @defproc[(build-list [n nat] [f (nat -> X)]) (listof X)]{ + Constructs a list by applying @racket[f] to the numbers between @racket[0] and @racket[(- n 1)]: + @codeblock{(build-list n f) = (list (f 0) ... (f (- n 1)))} + @interaction[#:eval (isl) + (build-list 22 add1) + i + (build-list 3 (lambda (j) (+ j i))) + (build-list 5 + (lambda (i) + (build-list 5 + (lambda (j) + (if (= i j) 1 0))))) + ] +} + @defproc[((intermediate-build-string build-string) [n nat] [f (nat -> char)]) string]{ + Constructs a string by applying @racket[f] to the numbers between @racket[0] and @racket[(- n 1)]: - @codeblock{(build-string n f) = (string (f 0) ... (f (- n 1)))} - @interaction[#:eval (isl) - (build-string 10 integer->char) - (build-string 26 (lambda (x) (integer->char (+ 65 x))))] - } - @defproc[((intermediate-quicksort quicksort) [l (listof X)] [comp (X X -> boolean)]) (listof X)]{ - Sorts the items on @racket[l], in an order according to @racket[comp] (using the quicksort + @codeblock{(build-string n f) = (string (f 0) ... (f (- n 1)))} + @interaction[#:eval (isl) + (build-string 10 integer->char) + (build-string 26 (lambda (x) (integer->char (+ 65 x))))] +} + @defproc[((intermediate-quicksort quicksort) [l (listof X)] [comp (X X -> boolean)]) (listof X)]{ + Sorts the items on @racket[l], in an order according to @racket[comp] (using the quicksort algorithm). - @interaction[#:eval (isl) - (quicksort '(6 7 2 1 3 4 0 5 9 8) <)] - } - @defproc[((intermediate-sort sort) [l (listof X)] [comp (X X -> boolean)]) (listof X)]{ - Sorts the items on @racket[l], in an order according to @racket[comp]. - @interaction[#:eval (isl) - (sort '(6 7 2 1 3 4 0 5 9 8) <)] - } - @defproc[((intermediate-andmap andmap) [p? (X ... -> boolean)] [l (listof X) ...]) boolean]{ - Determines whether @racket[p?] holds for all items of @racket[l] ...: - @codeblock{(andmap p (list x-1 ... x-n)) = (and (p x-1) ... (p x-n))} - @codeblock{(andmap p (list x-1 ... x-n) (list y-1 ... y-n)) = (and (p x-1 y-1) ... (p x-n y-n))} - @interaction[#:eval (isl) - (andmap odd? '(1 3 5 7 9)) - threshold - (andmap (lambda (x) (< x threshold)) '(0 1 2)) - (andmap even? '()) - (andmap (lambda (x f) (f x)) (list 0 1 2) (list odd? even? positive?)) - ] - } - @defproc[((intermediate-ormap ormap) [p? (X -> boolean)] [l (listof X)]) boolean]{ - Determines whether @racket[p?] holds for at least one items of @racket[l]: - @codeblock{(ormap p (list x-1 ... x-n)) = (or (p x-1) ... (p x-n))} - @codeblock{(ormap p (list x-1 ... x-n) (list y-1 ... y-n)) = (or (p x-1 y-1) ... (p x-n y-n))} - @interaction[#:eval (isl) - (ormap odd? '(1 3 5 7 9)) - threshold - (ormap (lambda (x) (< x threshold)) '(6 7 8 1 5)) - (ormap even? '()) - (ormap (lambda (x f) (f x)) (list 0 1 2) (list odd? even? positive?)) - ] - } - @defproc[(argmin [f (X -> real)] [l (listof X)]) X]{ - Finds the (first) element of the list that minimizes the output of the function. - @interaction[#:eval (isl) - (argmin second '((sam 98) (carl 78) (vincent 93) (asumu 99))) - ] - } - @defproc[(argmax [f (X -> real)] [l (listof X)]) X]{ - Finds the (first) element of the list that maximizes the output of the function. - @interaction[#:eval (isl) - (argmax second '((sam 98) (carl 78) (vincent 93) (asumu 99))) - ] - } - @defproc[(memf [p? (X -> any)] [l (listof X)]) (union #false (listof X))]{ - Produces @racket[#false] if @racket[p?] produces @racket[false] for all - items on @racket[l]. If @racket[p?] produces @racket[#true] for any of - the items on @racket[l], @racket[memf] returns the sub-list starting - from that item. - @interaction[#:eval (isl) - (memf odd? '(2 4 6 3 8 0)) - ] - } - @defproc[(apply [f (X-1 ... X-N -> Y)] [x-1 X-1] ... [l (list X-i+1 ... X-N)]) Y]{ - Applies a function using items from a list as the arguments: - @codeblock{(apply f (list x-1 ... x-n)) = (f x-1 ... x-n)} - @interaction[#:eval (isl) - a-list - (apply max a-list) - ] - } - @defproc[(compose [f (Y -> Z)] [g (X -> Y)]) (X -> Z)]{ - Composes a sequence of procedures into a single procedure: - @codeblock{(compose f g) = (lambda (x) (f (g x)))} - @interaction[#:eval (isl) - ((compose add1 second) '(add 3)) - (map (compose add1 second) '((add 3) (sub 2) (mul 4))) - ] - } - @defproc[(procedure? [x any]) boolean?]{ - Produces true if the value is a procedure. - @interaction[#:eval (isl) - (procedure? cons) - (procedure? add1) - (procedure? (lambda (x) (> x 22))) - ] - } - ) + @interaction[#:eval (isl) + (quicksort '(6 7 2 1 3 4 0 5 9 8) <)] +} + @defproc[((intermediate-sort sort) [l (listof X)] [comp (X X -> boolean)]) (listof X)]{ + Sorts the items on @racket[l], in an order according to @racket[comp]. + @interaction[#:eval (isl) + (sort '(6 7 2 1 3 4 0 5 9 8) <)] +} + @defproc[((intermediate-andmap andmap) [p? (X ... -> boolean)] [l (listof X) ...]) boolean]{ + Determines whether @racket[p?] holds for all items of @racket[l] ...: + @codeblock{(andmap p (list x-1 ... x-n)) = (and (p x-1) ... (p x-n))} + @codeblock{(andmap p (list x-1 ... x-n) (list y-1 ... y-n)) = (and (p x-1 y-1) ... (p x-n y-n))} + @interaction[#:eval (isl) + (andmap odd? '(1 3 5 7 9)) + threshold + (andmap (lambda (x) (< x threshold)) '(0 1 2)) + (andmap even? '()) + (andmap (lambda (x f) (f x)) (list 0 1 2) (list odd? even? positive?)) + ] +} + @defproc[((intermediate-ormap ormap) [p? (X -> boolean)] [l (listof X)]) boolean]{ + Determines whether @racket[p?] holds for at least one items of @racket[l]: + @codeblock{(ormap p (list x-1 ... x-n)) = (or (p x-1) ... (p x-n))} + @codeblock{(ormap p (list x-1 ... x-n) (list y-1 ... y-n)) = (or (p x-1 y-1) ... (p x-n y-n))} + @interaction[#:eval (isl) + (ormap odd? '(1 3 5 7 9)) + threshold + (ormap (lambda (x) (< x threshold)) '(6 7 8 1 5)) + (ormap even? '()) + (ormap (lambda (x f) (f x)) (list 0 1 2) (list odd? even? positive?)) + ] +} + @defproc[(argmin [f (X -> real)] [l (listof X)]) X]{ + Finds the (first) element of the list that minimizes the output of the function. + @interaction[#:eval (isl) + (argmin second '((sam 98) (carl 78) (vincent 93) (asumu 99))) + ] +} + @defproc[(argmax [f (X -> real)] [l (listof X)]) X]{ + Finds the (first) element of the list that maximizes the output of the function. + @interaction[#:eval (isl) + (argmax second '((sam 98) (carl 78) (vincent 93) (asumu 99))) + ] +} + @defproc[(memf [p? (X -> any)] [l (listof X)]) (union #false (listof X))]{ + Produces @racket[#false] if @racket[p?] produces @racket[false] for all + items on @racket[l]. If @racket[p?] produces @racket[#true] for any of + the items on @racket[l], @racket[memf] returns the sub-list starting + from that item. + @interaction[#:eval (isl) + (memf odd? '(2 4 6 3 8 0)) + ] +} + @defproc[(apply [f (X-1 ... X-N -> Y)] [x-1 X-1] ... [l (list X-i+1 ... X-N)]) Y]{ + Applies a function using items from a list as the arguments: + @codeblock{(apply f (list x-1 ... x-n)) = (f x-1 ... x-n)} + @interaction[#:eval (isl) + a-list + (apply max a-list) + ] +} + @defproc[(compose [f (Y -> Z)] [g (X -> Y)]) (X -> Z)]{ + Composes a sequence of procedures into a single procedure: + @codeblock{(compose f g) = (lambda (x) (f (g x)))} + @interaction[#:eval (isl) + ((compose add1 second) '(add 3)) + (map (compose add1 second) '((add 3) (sub 2) (mul 4))) + ] +} + @defproc[(procedure? [x any]) boolean?]{ + Produces true if the value is a procedure. + @interaction[#:eval (isl) + (procedure? cons) + (procedure? add1) + (procedure? (lambda (x) (> x 22))) + ] +} ) + ) diff -Nru racket-7.2+ppa2/share/pkgs/htdp-lib/lang/private/teachprims.rkt racket-7.3+ppa1/share/pkgs/htdp-lib/lang/private/teachprims.rkt --- racket-7.2+ppa2/share/pkgs/htdp-lib/lang/private/teachprims.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/htdp-lib/lang/private/teachprims.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -675,7 +675,63 @@ (cerr 'string-contains? (string? t) "string" t) (regexp-match? (regexp-quote (string-foldcase s)) (string-foldcase t)))) +(define-teach beginner string-append + (lambda (s t . args) + (apply string-append s t args))) + +(define-teach beginner string=? + (lambda (s t . args) + (apply string=? s t args))) + +(define-teach beginner string? + (lambda (s t . args) + (apply string>? s t args))) + +(define-teach beginner string<=? + (lambda (s t . args) + (apply string<=? s t args))) + +(define-teach beginner string>=? + (lambda (s t . args) + (apply string>=? s t args))) + +(define-teach beginner string-ci=? + (lambda (s t . args) + (apply string-ci=? s t args))) + +(define-teach beginner string-ci? + (lambda (s t . args) + (apply string-ci>? s t args))) + +(define-teach beginner string-ci<=? + (lambda (s t . args) + (apply string-ci<=? s t args))) + +(define-teach beginner string-ci>=? + (lambda (s t . args) + (apply string-ci>=? s t args))) + (provide + beginner-string-append + beginner-string=? + beginner-string? + beginner-string<=? + beginner-string>=? + beginner-string-ci=? + beginner-string-ci? + beginner-string-ci<=? + beginner-string-ci>=? + beginner-string-ith beginner-replicate beginner-int->string diff -Nru racket-7.2+ppa2/share/pkgs/htdp-lib/stepper/HISTORY.txt racket-7.3+ppa1/share/pkgs/htdp-lib/stepper/HISTORY.txt --- racket-7.2+ppa2/share/pkgs/htdp-lib/stepper/HISTORY.txt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/htdp-lib/stepper/HISTORY.txt 2019-05-16 01:29:07.000000000 +0000 @@ -1,6 +1,10 @@ Stepper ------- +Changes for 7.3: + +Bug fixes. + Changes for 7.2: Stepper now renames properly to avoid collisions on renamed variables. diff -Nru racket-7.2+ppa2/share/pkgs/htdp-lib/stepper/private/annotate.rkt racket-7.3+ppa1/share/pkgs/htdp-lib/stepper/private/annotate.rkt --- racket-7.2+ppa2/share/pkgs/htdp-lib/stepper/private/annotate.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/htdp-lib/stepper/private/annotate.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -690,7 +690,7 @@ (vector (wcm-wrap "supposed to be skipped" exp) null)] [else - (let ([exp (syntax-disarm exp saved-code-inspector)]) + (let ([exp (disarm exp)]) (recertifier (maybe-final-val-wrap (kernel:kernel-syntax-case @@ -1254,7 +1254,7 @@ (stepper-syntax-property stx 'stepper-black-box-expr)) stx] [else - (define disarmed-stx (syntax-disarm stx saved-code-inspector)) + (define disarmed-stx (disarm stx)) (define rewritten (kernel:kernel-syntax-case disarmed-stx @@ -1391,4 +1391,4 @@ ;; surprising but not a problem: (check-equal? (program-max-underscore #'(define x_0 'aoe_4)) 4) (check-equal? (program-max-underscore #'(define x_00 'aoe_04)) #f) - ) \ No newline at end of file + ) diff -Nru racket-7.2+ppa2/share/pkgs/htdp-lib/stepper/private/shared.rkt racket-7.3+ppa1/share/pkgs/htdp-lib/stepper/private/shared.rkt --- racket-7.2+ppa2/share/pkgs/htdp-lib/stepper/private/shared.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/htdp-lib/stepper/private/shared.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -41,7 +41,7 @@ break-kind? ; predicate re-intern-identifier finished-xml-box-table - saved-code-inspector + disarm (struct-out annotated-proc) view-controller^ stepper-frame^ @@ -114,8 +114,10 @@ (define saved-code-inspector (variable-reference->module-declaration-inspector (#%variable-reference))) +(define (disarm stx) (syntax-disarm stx saved-code-inspector)) -(define (rebuild-stx new old) +(define (rebuild-stx new old/maybe-armed) + (define old (disarm old/maybe-armed)) (datum->syntax old new old old)) (define break-kind? @@ -197,7 +199,7 @@ (cond [(syntax? stx) (define up (up-fn-finder 'syntax-e)) - (up stx (update fn-list (syntax-e stx) core-fn up-fn-finder))] + (up stx (update fn-list (syntax-e (disarm 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): diff -Nru racket-7.2+ppa2/share/pkgs/htdp-lib/teachpack/HISTORY.txt racket-7.3+ppa1/share/pkgs/htdp-lib/teachpack/HISTORY.txt --- racket-7.2+ppa2/share/pkgs/htdp-lib/teachpack/HISTORY.txt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/htdp-lib/teachpack/HISTORY.txt 2019-05-16 01:29:07.000000000 +0000 @@ -1,3 +1,11 @@ +Version 7.3 [Fri May 10 11:08:51 EDT 2019] + +* change signature for + string-append, string=?, string?, string<=?, string>=?, + string-ci=?, string-ci?, string-ci<=?, string-ci>=? + so that they take at least two arguments in BSL + and can be used with fold and friends in ISL and ISL+ + ------------------------------------------------------------------------ Version 7.2 [Mon Jan 28 10:29:15 EST 2019] diff -Nru racket-7.2+ppa2/share/pkgs/htdp-lib/test-engine/racket-tests.rkt racket-7.3+ppa1/share/pkgs/htdp-lib/test-engine/racket-tests.rkt --- racket-7.2+ppa2/share/pkgs/htdp-lib/test-engine/racket-tests.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/htdp-lib/test-engine/racket-tests.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -104,7 +104,7 @@ (#,checker-proc-stx #,(with-stepper-syntax-properties (['stepper-hide-reduction #t]) - #`(car + #`(car #,(with-stepper-syntax-properties (['stepper-hide-reduction #t]) #`(list @@ -178,15 +178,8 @@ (define-syntax (check-random stx) (syntax-case stx () [(check-random e1 e2) - (let ([test - #`(lambda (rng k) - (parameterize ((current-pseudo-random-generator rng)) (random-seed k) - e1))] - [actuals - (list - #`(lambda (rng k) - (parameterize ((current-pseudo-random-generator rng)) (random-seed k) - e2)))]) + (let ([test #`(lambda () e1)] + [actuals (list #`(lambda () e2))]) (check-expect-maker stx #'check-random-values test actuals 'comes-from-check-expect))] [_ (raise-syntax-error 'check-random (argcount-error-message/stx 2 stx) stx)])) @@ -258,18 +251,21 @@ test-engine (list 'check-satisfied name))) -;; check-values-expected: (-> scheme-val) (-> nat scheme-val) src test-engine -> void -(define (check-random-values test actual-maker src test-engine) +;; check-values-expected: (-> scheme-val) (-> scheme-val) src test-engine -> void +(define (check-random-values test-maker actual-maker src test-engine) (define rng (make-pseudo-random-generator)) (define k (modulo (current-milliseconds) (sub1 (expt 2 31)))) - (define actual (actual-maker rng k)) + (define actual (parameterize ([current-pseudo-random-generator rng]) + (random-seed k) + (actual-maker))) (error-check (lambda (v) (if (number? v) (exact? v) #t)) actual INEXACT-NUMBERS-FMT #t) - (error-check (lambda (v) (not (procedure? v))) actual FUNCTION-FMT #f) (send (send test-engine get-info) add-check) (run-and-check (lambda (v1 v2 _) (teach-equal? v1 v2)) (lambda (src format v1 v2 _) (make-unequal src format v1 v2)) - (lambda () ((test) rng k)) + (lambda () (parameterize ([current-pseudo-random-generator rng]) + (random-seed k) + ((test-maker)))) actual #f src @@ -316,7 +312,8 @@ [(_ test) (check-expect-maker stx #'check-values-error/no-string #`test null 'comes-from-check-error)] - [_ (raise-syntax-error 'check-error (argcount-error-message/stx 1 stx #t) stx)])) + [(_) (raise-syntax-error 'check-error (argcount-error-message/stx 1 stx #t) stx)] + [_ (raise-syntax-error 'check-error (argcount-error-message/stx 2 stx) stx)])) ;; check-values-error: (-> scheme-val) scheme-val src test-engine -> void (define (check-values-error test error src test-engine) diff -Nru racket-7.2+ppa2/share/pkgs/htdp-lib/typed/test-engine/type-env-ext.rkt racket-7.3+ppa1/share/pkgs/htdp-lib/typed/test-engine/type-env-ext.rkt --- racket-7.2+ppa2/share/pkgs/htdp-lib/typed/test-engine/type-env-ext.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/htdp-lib/typed/test-engine/type-env-ext.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -77,6 +77,15 @@ (when _ (insert-test _ (lambda () (check-member-of-values-expected _ _ _ _ _)))))) #'check-member-of-values-expected]) - ((-> Univ) Univ (-lst Univ) Univ Univ . -> . -Void)])) + ((-> Univ) Univ (-lst Univ) Univ Univ . -> . -Void)] + ;; check-random-values + [(syntax-parse (local-expand #'(ce:check-random 1 1) 'module #f) + #:literals (let* when define-values) + [(define-values _ + (let* ((_ _) (_ _)) + (when _ + (insert-test _ (lambda () (check-random-values _ _ _ _)))))) + #'check-random-values]) + ((-> Univ) (-> Univ) (-lst Univ) Univ . -> . -Void)])) (begin-for-syntax (initialize-type-env ce-env)) diff -Nru racket-7.2+ppa2/share/pkgs/html/info.rkt racket-7.3+ppa1/share/pkgs/html/info.rkt --- racket-7.2+ppa2/share/pkgs/html/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/html/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/html-doc/info.rkt racket-7.3+ppa1/share/pkgs/html-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/html-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/html-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/html-lib/info.rkt racket-7.3+ppa1/share/pkgs/html-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/html-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/html-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/icons/info.rkt racket-7.3+ppa1/share/pkgs/icons/info.rkt --- racket-7.2+ppa2/share/pkgs/icons/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/icons/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/images/info.rkt racket-7.3+ppa1/share/pkgs/images/info.rkt --- racket-7.2+ppa2/share/pkgs/images/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/images/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/images-doc/info.rkt racket-7.3+ppa1/share/pkgs/images-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/images-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/images-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/images-gui-lib/info.rkt racket-7.3+ppa1/share/pkgs/images-gui-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/images-gui-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/images-gui-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/images-lib/info.rkt racket-7.3+ppa1/share/pkgs/images-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/images-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/images-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/lazy/info.rkt racket-7.3+ppa1/share/pkgs/lazy/info.rkt --- racket-7.2+ppa2/share/pkgs/lazy/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/lazy/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/macro-debugger/info.rkt racket-7.3+ppa1/share/pkgs/macro-debugger/info.rkt --- racket-7.2+ppa2/share/pkgs/macro-debugger/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/macro-debugger/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/macro-debugger-text-lib/info.rkt racket-7.3+ppa1/share/pkgs/macro-debugger-text-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/macro-debugger-text-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/macro-debugger-text-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.3"))) (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-7.2+ppa2/share/pkgs/main-distribution/info.rkt racket-7.3+ppa1/share/pkgs/main-distribution/info.rkt --- racket-7.2+ppa2/share/pkgs/main-distribution/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/main-distribution/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/make/info.rkt racket-7.3+ppa1/share/pkgs/make/info.rkt --- racket-7.2+ppa2/share/pkgs/make/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/make/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/math/info.rkt racket-7.3+ppa1/share/pkgs/math/info.rkt --- racket-7.2+ppa2/share/pkgs/math/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/math/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/math-doc/info.rkt racket-7.3+ppa1/share/pkgs/math-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/math-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/math-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/math-lib/info.rkt racket-7.3+ppa1/share/pkgs/math-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/math-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/math-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/mysterx/info.rkt racket-7.3+ppa1/share/pkgs/mysterx/info.rkt --- racket-7.2+ppa2/share/pkgs/mysterx/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/mysterx/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/mzcom/info.rkt racket-7.3+ppa1/share/pkgs/mzcom/info.rkt --- racket-7.2+ppa2/share/pkgs/mzcom/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/mzcom/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/mzscheme/info.rkt racket-7.3+ppa1/share/pkgs/mzscheme/info.rkt --- racket-7.2+ppa2/share/pkgs/mzscheme/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/mzscheme/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/mzscheme-doc/info.rkt racket-7.3+ppa1/share/pkgs/mzscheme-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/mzscheme-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/mzscheme-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/mzscheme-lib/compiler/main.rkt racket-7.3+ppa1/share/pkgs/mzscheme-lib/compiler/main.rkt --- racket-7.2+ppa2/share/pkgs/mzscheme-lib/compiler/main.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/mzscheme-lib/compiler/main.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -523,7 +523,9 @@ (mzc:create-embedding-executable dest #:mred? (eq? mode 'gui-exe) - #:variant (if (compiler:option:3m) '3m 'cgc) + #:variant (if (eq? 'racket (system-type 'vm)) + (if (compiler:option:3m) '3m 'cgc) + (system-type 'gc)) #:verbose? (compiler:option:verbose) #:modules (cons `(#%mzc: (file ,(car source-files))) (map (lambda (l) `(#t (lib ,l))) diff -Nru racket-7.2+ppa2/share/pkgs/mzscheme-lib/info.rkt racket-7.3+ppa1/share/pkgs/mzscheme-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/mzscheme-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/mzscheme-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/net/info.rkt racket-7.3+ppa1/share/pkgs/net/info.rkt --- racket-7.2+ppa2/share/pkgs/net/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/net/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/net-cookies/info.rkt racket-7.3+ppa1/share/pkgs/net-cookies/info.rkt --- racket-7.2+ppa2/share/pkgs/net-cookies/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/net-cookies/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/net-cookies-doc/info.rkt racket-7.3+ppa1/share/pkgs/net-cookies-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/net-cookies-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/net-cookies-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/net-cookies-lib/info.rkt racket-7.3+ppa1/share/pkgs/net-cookies-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/net-cookies-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/net-cookies-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/net-doc/info.rkt racket-7.3+ppa1/share/pkgs/net-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/net-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/net-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/net-doc/net/scribblings/git-checkout.scrbl racket-7.3+ppa1/share/pkgs/net-doc/net/scribblings/git-checkout.scrbl --- racket-7.2+ppa2/share/pkgs/net-doc/net/scribblings/git-checkout.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/net-doc/net/scribblings/git-checkout.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -29,8 +29,8 @@ (apply printf args) (flush-output))] [#:initial-error initial-error (or #f (-> any)) #f] - [#:tmp-dir given-tmp-dir (or/c #f path-string?) #f] - [#:clean-tmp-dir? clean-tmp-dir? any/c (not given-tmp-dir)] + [#:tmp-dir tmp-dir (or/c #f path-string?) #f] + [#:clean-tmp-dir? clean-tmp-dir? any/c (not tmp-dir)] [#:verify-server? verify-server? any/c #t] [#:port port (or/c #f (integer-in 1 65535)) (case transport [(git) 9418] @@ -75,7 +75,7 @@ @racket[git-checkout] to obtain only the latest commit and its objects, instead of the entire history of the branch or commit. If @racket[ref] is any other commit ID or tree ID, then the entire -repository is downloaded, including all branches. +repository may have to be downloaded, including all branches. Status information is reported via @racket[status-printf]. The same information is always logged with the name @racket['git-checkout] at diff -Nru racket-7.2+ppa2/share/pkgs/net-lib/info.rkt racket-7.3+ppa1/share/pkgs/net-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/net-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/net-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/optimization-coach/info.rkt racket-7.3+ppa1/share/pkgs/optimization-coach/info.rkt --- racket-7.2+ppa2/share/pkgs/optimization-coach/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/optimization-coach/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/option-contract/info.rkt racket-7.3+ppa1/share/pkgs/option-contract/info.rkt --- racket-7.2+ppa2/share/pkgs/option-contract/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/option-contract/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/option-contract-doc/info.rkt racket-7.3+ppa1/share/pkgs/option-contract-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/option-contract-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/option-contract-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/option-contract-lib/info.rkt racket-7.3+ppa1/share/pkgs/option-contract-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/option-contract-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/option-contract-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/parser-tools/info.rkt racket-7.3+ppa1/share/pkgs/parser-tools/info.rkt --- racket-7.2+ppa2/share/pkgs/parser-tools/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/parser-tools/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/parser-tools-doc/info.rkt racket-7.3+ppa1/share/pkgs/parser-tools-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/parser-tools-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/parser-tools-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/parser-tools-lib/info.rkt racket-7.3+ppa1/share/pkgs/parser-tools-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/parser-tools-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/parser-tools-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/pconvert-lib/info.rkt racket-7.3+ppa1/share/pkgs/pconvert-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/pconvert-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/pconvert-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/pict/info.rkt racket-7.3+ppa1/share/pkgs/pict/info.rkt --- racket-7.2+ppa2/share/pkgs/pict/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/pict/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/pict-doc/info.rkt racket-7.3+ppa1/share/pkgs/pict-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/pict-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/pict-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/pict-doc/pict/scribblings/pict.scrbl racket-7.3+ppa1/share/pkgs/pict-doc/pict/scribblings/pict.scrbl --- racket-7.2+ppa2/share/pkgs/pict-doc/pict/scribblings/pict.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/pict-doc/pict/scribblings/pict.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -943,6 +943,26 @@ } +@defproc[(shear [pict pict-convertible?] [x-shear number?] [y-shear number?]) pict?]{ + + Shear's the @racket[pict] by a factor of @racket[x-shear] + along the x-axis and by a factor of @racket[y-shear] along + the y-axis. The bounding box is inflated to + contain the result. The result's ascent and descent + are the same as @racket[pict]'s. + + @examples[#:eval ss-eval + (define sqr + (colorize (filled-rectangle 40 20 #:draw-border? #t #:color "purple") + "black")) + (shear sqr 0 0.3) + (shear sqr -0.5 0) + (shear sqr -0.5 0.3)] + + @history[#:added "1.8"]{} +} + + @defproc[(ghost [pict pict-convertible?]) pict?]{ Creates a container picture that doesn't draw the child picture, diff -Nru racket-7.2+ppa2/share/pkgs/pict-doc/pict/scribblings/tree-layout.scrbl racket-7.3+ppa1/share/pkgs/pict-doc/pict/scribblings/tree-layout.scrbl --- racket-7.2+ppa2/share/pkgs/pict-doc/pict/scribblings/tree-layout.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/pict-doc/pict/scribblings/tree-layout.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -25,11 +25,11 @@ to @racket[tree-edge]. Children that are @racket[#f] correspond to leaf nodes that are not drawn. - The default @racket[node-pict] (used when it is @racket[#f]) is - @default-node-pict + The default @racket[node-pict] (used when @racket[node-pict] is @racket[#f]) + is @|default-node-pict|. } -@defproc[(tree-edge [node tree-layout?] +@defproc[(tree-edge [node (and/c tree-layout? (not/c #f))] [#:edge-color edge-color (or/c string? (is-a?/c color%) @@ -37,23 +37,34 @@ "gray"] [#:edge-width edge-width (or/c 'unspecified real? #f) + 'unspecified] + [#:edge-style edge-style + (or/c 'unspecified 'transparent 'solid 'xor 'hilite + 'dot 'long-dash 'short-dash 'dot-dash + 'xor-dot 'xor-long-dash 'xor-short-dash + 'xor-dot-dash) 'unspecified]) tree-edge?]{ This function specifies an edge from some parent to the given @racket[node]. - It it intended to be used with @racket[tree-layout]. + It it intended to be used with @racket[tree-layout], on a non-@racket[#f] node. When @racket[edge-width] is @racket['unspecified], the line width will not be set. This is intended to allow the line width to be set for the whole pict via @racket[linewidth]. Otherwise, @racket[edge-width] is interpreted the same way as the width argument for the @racket[linewidth] function. + @racket[edge-style] behaves similarly, its argument interpreted as the style + argument for the @racket[linestyle] function. @examples[#:eval tree-layout-eval (naive-layered (tree-layout (tree-edge #:edge-width 3 (tree-layout)) - (tree-edge #:edge-color "green" (tree-layout))))] + (tree-edge #:edge-color "red" + #:edge-style 'dot + (tree-layout))))] - @history[#:changed "6.1.0.5" "Added an #:edge-width option"] + @history[#:changed "1.3" @list{Added the @racket[#:edge-width] option.} + #:changed "1.9" @list{Added the @racket[#:edge-style] option.}] } @defproc[(tree-layout? [v any/c]) boolean?]{ diff -Nru racket-7.2+ppa2/share/pkgs/pict-lib/info.rkt racket-7.3+ppa1/share/pkgs/pict-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/pict-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/pict-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.8"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.3"))) (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.8"))) diff -Nru racket-7.2+ppa2/share/pkgs/pict-lib/pict/private/hv.rkt racket-7.3+ppa1/share/pkgs/pict-lib/pict/private/hv.rkt --- racket-7.2+ppa2/share/pkgs/pict-lib/pict/private/hv.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/pict-lib/pict/private/hv.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -21,21 +21,21 @@ (match t [#f (blank)] [(tree-layout pict (list left right)) - (define-values (left-t left-color left-width) + (define-values (left-t left-color left-width left-style) (match left - [#f (values #f #f #f)] - [(tree-edge child color width) (values child color width)])) - (define-values (right-t right-color right-width) + [#f (values #f #f #f #f)] + [(tree-edge child color width style) (values child color width style)])) + (define-values (right-t right-color right-width right-style) (match right - [#f (values #f #f #f)] - [(tree-edge child color width) (values child color width)])) + [#f (values #f #f #f #f)] + [(tree-edge child color width style) (values child color width style)])) (cond [(and (not left-t) (not right-t)) (dot-ize pict)] [(not left-t) - (empty-left (dot-ize pict) x-spacing right-color right-width (loop right-t (not l)))] + (empty-left (dot-ize pict) x-spacing right-color right-width right-style (loop right-t (not l)))] [(not right-t) - (empty-right (dot-ize pict) y-spacing left-color left-width (loop left-t (not l)))] + (empty-right (dot-ize pict) y-spacing left-color left-width left-style (loop left-t (not l)))] [else (define left-p (loop left-t (not l))) (define right-p (loop right-t (not l))) @@ -44,7 +44,8 @@ x-spacing y-spacing left-p right-p)) (pin-over - (add-lines main left-color right-color left-width right-width left-p right-p) + (add-lines main left-color right-color left-width right-width left-style right-style + left-p right-p) (- (/ (pict-width pict) 2)) (- (/ (pict-height pict) 2)) pict)])])) @@ -67,23 +68,23 @@ (ht-append (blank hgap 0) left) right)) -(define (empty-left pict hgap color width sub-tree-p) +(define (empty-left pict hgap color width style sub-tree-p) (add-a-line (ht-append hgap pict sub-tree-p) color - width + width style sub-tree-p)) -(define (empty-right pict vgap color width sub-tree-p) +(define (empty-right pict vgap color width style sub-tree-p) (add-a-line (vl-append vgap pict sub-tree-p) color - width + width style sub-tree-p)) -(define (add-lines main left-color right-color left-width right-width t1 t2) - (add-a-line (add-a-line main left-color left-width t1) - right-color right-width t2)) +(define (add-lines main left-color right-color left-width right-width left-style right-style t1 t2) + (add-a-line (add-a-line main left-color left-width left-style t1) + right-color right-width right-style t2)) -(define (add-a-line main color width sub) +(define (add-a-line main color width style sub) (define colored (colorize (pin-line (ghost main) @@ -94,8 +95,10 @@ (if (eq? width 'unspecified) colored (linewidth width colored))) + (define with-linestyle + (if (eq? style 'unspecified) with-linewidth (linestyle style with-linewidth))) (cc-superimpose - (launder with-linewidth) + (launder with-linestyle) main)) (module+ test diff -Nru racket-7.2+ppa2/share/pkgs/pict-lib/pict/private/layout.rkt racket-7.3+ppa1/share/pkgs/pict-lib/pict/private/layout.rkt --- racket-7.2+ppa2/share/pkgs/pict-lib/pict/private/layout.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/pict-lib/pict/private/layout.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -12,7 +12,7 @@ ;; values of this struct leak outside, so it cannot be transparent (struct tree-layout (pict children)) -(struct tree-edge (child edge-color edge-width)) +(struct tree-edge (child edge-color edge-width edge-style)) (define _tree-layout (let ([constructor tree-layout]) @@ -41,8 +41,9 @@ (let ([constructor tree-edge]) (define (tree-edge child #:edge-color [edge-color "gray"] - #:edge-width [edge-width 'unspecified]) - (constructor child edge-color edge-width)) + #:edge-width [edge-width 'unspecified] + #:edge-style [edge-style 'unspecified]) + (constructor child edge-color edge-width edge-style)) tree-edge)) (define (binary-tree-layout? t) @@ -55,7 +56,7 @@ (define (binary-tree-edge? e) (match e - [(tree-edge t _ _) (binary-tree-layout? t)] + [(tree-edge t _ _ _) (binary-tree-layout? t)] [#f #t])) (define (compute-spacing t given-x-spacing given-y-spacing) @@ -75,7 +76,7 @@ (for ([edge (in-list children)]) (match edge [#f (void)] - [(tree-edge child edge-color _) + [(tree-edge child edge-color _ _) (loop child)]))])) (values (or given-x-spacing x-spacing) diff -Nru racket-7.2+ppa2/share/pkgs/pict-lib/pict/private/naive-layered.rkt racket-7.3+ppa1/share/pkgs/pict-lib/pict/private/naive-layered.rkt --- racket-7.2+ppa2/share/pkgs/pict-lib/pict/private/naive-layered.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/pict-lib/pict/private/naive-layered.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -22,7 +22,7 @@ [#f (define b (blank)) (cons b b)] - [(tree-edge child color _) + [(tree-edge child color _ _) (loop child)]))) (define this-root (launder (ghost pict))) (define children-roots (map car children-pairs)) @@ -43,7 +43,7 @@ (define this-tree-edge (car tree-edges)) (match this-tree-edge [#f (loop main (cdr children-roots) (cdr tree-edges))] - [(tree-edge child edge-color edge-width) + [(tree-edge child edge-color edge-width edge-style) (define *w/line (colorize (launder @@ -52,9 +52,13 @@ child-root cc-find)) edge-color)) (define w/line - (if (eq? edge-width 'unspecified) - *w/line - (linewidth edge-width *w/line))) + (let ([w/width + (if (eq? edge-width 'unspecified) + *w/line + (linewidth edge-width *w/line))]) + (if (eq? edge-style 'unspecified) + w/width + (linestyle edge-style w/width)))) (loop (cc-superimpose w/line main) (cdr children-roots) (cdr tree-edges))])]))])]))) diff -Nru racket-7.2+ppa2/share/pkgs/pict-lib/pict/private/pict.rkt racket-7.3+ppa1/share/pkgs/pict-lib/pict/private/pict.rkt --- racket-7.2+ppa2/share/pkgs/pict-lib/pict/private/pict.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/pict-lib/pict/private/pict.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -567,12 +567,12 @@ (values x1 y1 x2 y2 ay dy)) (let ([c (car l)]) (let-values ([(cx1 cy1 cx2 cy2 cay cdy) (panorama-box! (child-pict c))]) - (loop (min x1 (* (+ cx1 (child-dx c)) (child-sx c))) - (min y1 (* (+ cy1 (child-dy c)) (child-sy c))) - (max x2 (* (+ cx2 (child-dx c)) (child-sx c))) - (max y2 (* (+ cy2 (child-dy c)) (child-sy c))) - (max ay (* (+ cay (child-dy c)) (child-sy c))) - (min dy (* (+ cdy (child-dy c)) (child-sy c))) + (loop (min x1 (+ (* cx1 (child-sx c)) (child-dx c))) + (min y1 (+ (* cy1 (child-sy c)) (child-dy c))) + (max x2 (+ (* cx2 (child-sx c)) (child-dx c))) + (max y2 (+ (* cy2 (child-sy c)) (child-dy c))) + (max ay (+ (* cay (child-sy c)) (child-dy c))) + (min dy (+ (* cdy (child-sy c)) (child-dy c))) (cdr l))))))))) (define (panorama p) diff -Nru racket-7.2+ppa2/share/pkgs/pict-lib/pict/private/tidier.rkt racket-7.3+ppa1/share/pkgs/pict-lib/pict/private/tidier.rkt --- racket-7.2+ppa2/share/pkgs/pict-lib/pict/private/tidier.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/pict-lib/pict/private/tidier.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -46,7 +46,7 @@ (* x x-spacing) (* y y-spacing) node-pict)) - (define (add-edge to color width) + (define (add-edge to color width style) (define colored (colorize (launder (pin-line (ghost main) node-pict cc-find @@ -56,17 +56,21 @@ (if (eq? width 'unspecified) colored (linewidth width colored))) - (set! main (cc-superimpose with-linewidth main))) + (define with-linestyle + (if (eq? style 'unspecified) + with-linewidth + (linestyle style with-linewidth))) + (set! main (cc-superimpose with-linestyle main))) (match left-t [#f (void)] - [(tree-edge left-t left-color left-width) + [(tree-edge left-t left-color left-width left-style) (define left-pict (loop left-t left-xc (+ y 1))) - (add-edge left-pict left-color left-width)]) + (add-edge left-pict left-color left-width left-style)]) (match right-t [#f (void)] - [(tree-edge right-t right-color right-width) + [(tree-edge right-t right-color right-width right-style) (define right-pict (loop right-t right-xc (+ y 1))) - (add-edge right-pict right-color right-width)]) + (add-edge right-pict right-color right-width right-style)]) node-pict])) main] diff -Nru racket-7.2+ppa2/share/pkgs/pict-lib/pict/private/utils.rkt racket-7.3+ppa1/share/pkgs/pict-lib/pict/private/utils.rkt --- racket-7.2+ppa2/share/pkgs/pict-lib/pict/private/utils.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/pict-lib/pict/private/utils.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -73,6 +73,7 @@ [scale-to-fit (->* (pict-convertible? (or/c number? pict-convertible?)) (number? #:mode (or/c 'preserve 'inset 'preserve/max 'inset/max 'distort)) pict?)] + [shear (-> pict-convertible? number? number? pict?)] [rotate (case-> (-> pict-convertible? number? pict?))] [pin-line (->* (pict-convertible? pict-path? (-> pict? pict-path? (values number? number?)) @@ -1201,6 +1202,30 @@ (pict-last p))] [(p factor) (scale p factor factor)])) +(define (shear p shear-x shear-y) + (define drawer (make-pict-drawer p)) + (define x-shift (* shear-x (pict-height p))) + (define y-shift (* shear-y (pict-width p))) + (define new + (dc + (λ (dc dx dy) + (define t (send dc get-transformation)) + (send dc transform (vector 1 shear-y shear-x 1 (- dx (min 0 x-shift)) (- dy (min 0 y-shift)))) + (drawer dc 0 0) + (send dc set-transformation t)) + (+ (pict-width p) (abs x-shift)) + (+ (pict-height p) (abs y-shift)) + (pict-ascent p) + (pict-descent p))) + (make-pict (pict-draw new) + (pict-width new) + (pict-height new) + (pict-ascent new) + (pict-descent new) + (list (make-child p 0 0 1 1 shear-y shear-x)) + #f + (pict-last p))) + (define (rotate p theta) (let ([w (pict-width p)] [h (pict-height p)] diff -Nru racket-7.2+ppa2/share/pkgs/pict-lib/pict/tree-layout.rkt racket-7.3+ppa1/share/pkgs/pict-lib/pict/tree-layout.rkt --- racket-7.2+ppa2/share/pkgs/pict-lib/pict/tree-layout.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/pict-lib/pict/tree-layout.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -19,11 +19,16 @@ tree-layout?)] [rename _tree-edge tree-edge - (->* (tree-layout?) + (->* ((and/c _tree-layout? (not/c #f))) (#:edge-color (or/c string? (is-a?/c color%) (list/c byte? byte? byte?)) - #:edge-width (or/c 'unspecified real? #f)) + #:edge-width (or/c 'unspecified real? #f) + #:edge-style (or/c 'unspecified + 'transparent 'solid 'xor 'hilite + 'dot 'long-dash 'short-dash 'dot-dash + 'xor-dot 'xor-long-dash 'xor-short-dash + 'xor-dot-dash)) tree-edge?)] diff -Nru racket-7.2+ppa2/share/pkgs/pict-lib/texpict/code.rkt racket-7.3+ppa1/share/pkgs/pict-lib/texpict/code.rkt --- racket-7.2+ppa2/share/pkgs/pict-lib/texpict/code.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/pict-lib/texpict/code.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -152,7 +152,7 @@ #`(typeset-code #,(cvt ;; Avoid a syntax location for the synthesized `code:line` wrapper, ;; otherwise the `expr`s will be arranged relative to it: - (datum->syntax #f (cons 'code:line #'(expr (... ...))))))])))] + (datum->syntax #f (cons 'code:line (datum->syntax #f (syntax-e #'(expr (... ...))))))))])))] [(_ code typeset-code) #'(define-code code typeset-code unsyntax)])) (define-signature code^ diff -Nru racket-7.2+ppa2/share/pkgs/pict-snip/info.rkt racket-7.3+ppa1/share/pkgs/pict-snip/info.rkt --- racket-7.2+ppa2/share/pkgs/pict-snip/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/pict-snip/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/pict-snip-doc/info.rkt racket-7.3+ppa1/share/pkgs/pict-snip-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/pict-snip-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/pict-snip-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/pict-snip-lib/info.rkt racket-7.3+ppa1/share/pkgs/pict-snip-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/pict-snip-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/pict-snip-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/picturing-programs/info.rkt racket-7.3+ppa1/share/pkgs/picturing-programs/info.rkt --- racket-7.2+ppa2/share/pkgs/picturing-programs/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/picturing-programs/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/pkgs.rktd racket-7.3+ppa1/share/pkgs/pkgs.rktd --- racket-7.2+ppa2/share/pkgs/pkgs.rktd 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/pkgs.rktd 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -#hash(("2d" . #s(pkg-info (catalog "2d") "fdaf085417cc18404e9cf8f9fb4f9f9b694aa64b" #t)) ("2d-doc" . #s((sc-pkg-info pkg-info 3) (catalog "2d-doc") "80bc8365ba8f7d7b88ded856c2d75fe2adc2ad65" #t "2d")) ("2d-lib" . #s((sc-pkg-info pkg-info 3) (catalog "2d-lib") "2191d5db2b816a0b1b0256323ca746527d949430" #t "2d")) ("algol60" . #s((sc-pkg-info pkg-info 3) (catalog "algol60") "3288be870d95d0053beb8d7eb46d4c53f8e50acb" #t "algol60")) ("at-exp-lib" . #s(pkg-info (catalog "at-exp-lib") "6e4e7cf05e3eac47f1e6e976a150ff77c0f87fe6" #t)) ("base" . #s(pkg-info (catalog "base") "a406bc74d583ac7a61f651e5331bcfd0ecc1f73b" #t)) ("cext-lib" . #s(pkg-info (catalog "cext-lib") "2b7b132748f4a5f08823a8c06b37dac6f1577b25" #t)) ("class-iop-lib" . #s(pkg-info (catalog "class-iop-lib") "c02c07a9cbb598eca9a3bbb7675317e60a922695" #t)) ("compatibility" . #s(pkg-info (catalog "compatibility") "f72340d49fe270fc1e485c0f41af25d7157ae30d" #t)) ("compatibility-doc" . #s(pkg-info (catalog "compatibility-doc") "fff14f522d74b97cfb5ae32feb4df02d1da3654d" #t)) ("compatibility-lib" . #s(pkg-info (catalog "compatibility-lib") "607a16c5817fcaf1264cdd18cdb7568dc9911207" #t)) ("compiler" . #s(pkg-info (catalog "compiler") "d42d3a3c62057e5a05408f60b490e4f834164357" #t)) ("compiler-lib" . #s(pkg-info (catalog "compiler-lib") "a8fbb5b648137758ea53266a92b306b6c4f87b29" #t)) ("contract-profile" . #s((sc-pkg-info pkg-info 3) (catalog "contract-profile") "c3ba5b53acbfd6e792c776f85007c42d87437249" #t "contract-profile")) ("data" . #s(pkg-info (catalog "data") "7e22a1737de1b67656ee1444931081a73f7c83a1" #t)) ("data-doc" . #s(pkg-info (catalog "data-doc") "d5fb9d883d4e8a3c4bf1226485b516545d52b31b" #t)) ("data-enumerate-lib" . #s(pkg-info (catalog "data-enumerate-lib") "9d9553485d3306fc49a46fd42155802044ac4954" #t)) ("data-lib" . #s(pkg-info (catalog "data-lib") "1c731a8ad28dced8518eacb3021763d4996fa2c9" #t)) ("datalog" . #s((sc-pkg-info pkg-info 3) (catalog "datalog") "1ecded81525c61c9cf142a69a7d1da575a5a95e6" #t "datalog")) ("db" . #s(pkg-info (catalog "db") "1dbd5264a1f92ef405bb7b8d2557a9dc2b88ebaa" #t)) ("db-doc" . #s(pkg-info (catalog "db-doc") "69c0f5610f60c954538d509ccae4e0b94247e675" #t)) ("db-lib" . #s(pkg-info (catalog "db-lib") "996184d8a7a3e97a6ff411db3a78a5bdc30b2284" #t)) ("deinprogramm" . #s(pkg-info (catalog "deinprogramm") "0c59dbe4af2bb3e9acd52b1c6fcab4138ea65021" #t)) ("deinprogramm-signature" . #s(pkg-info (catalog "deinprogramm-signature") "20a7f5db21c4677a60895f5a712791a7607d09b6" #t)) ("distributed-places" . #s(pkg-info (catalog "distributed-places") "4ea0b2edde868a7eb719d413ec953891af222c6c" #t)) ("distributed-places-doc" . #s(pkg-info (catalog "distributed-places-doc") "e0bc5582ba60351de4a175936c46fbc76c832cbe" #t)) ("distributed-places-lib" . #s(pkg-info (catalog "distributed-places-lib") "e60eaaf07cbf3319108ae2dc113a1fc4b30c734c" #t)) ("draw" . #s(pkg-info (catalog "draw") "9ba802253b34b7b129f8d89bdcdf1e00ca84adfd" #t)) ("draw-doc" . #s(pkg-info (catalog "draw-doc") "d67a673b3dfddb29e49042481e42b9b41a1f3fbf" #t)) ("draw-lib" . #s(pkg-info (catalog "draw-lib") "153941cf72288694efa834fcadabdaa1d95e62f9" #t)) ("drracket" . #s(pkg-info (catalog "drracket") "9f926cfeb988871c83e4d81479638da437c79ffa" #t)) ("drracket-plugin-lib" . #s(pkg-info (catalog "drracket-plugin-lib") "21f74a83d8b287310623c6b4ec888e8b0fd39743" #t)) ("drracket-tool" . #s(pkg-info (catalog "drracket-tool") "0b490b366c52bbf49f7a6ffde36eb02abbfbe7ff" #t)) ("drracket-tool-doc" . #s(pkg-info (catalog "drracket-tool-doc") "a8275c3534626f98e787d33a67b593bcb884ea0c" #t)) ("drracket-tool-lib" . #s(pkg-info (catalog "drracket-tool-lib") "7054cb11abd6c3efd3381fc61b68ad27a88ff3ee" #t)) ("ds-store" . #s((sc-pkg-info pkg-info 3) (catalog "ds-store") "d3348321c9e98c83b4ba3d70ce1efdbcd26cde03" #t "ds-store")) ("ds-store-doc" . #s((sc-pkg-info pkg-info 3) (catalog "ds-store-doc") "6681c3f694cfb51c55494392cc9f161958657b6e" #t "ds-store")) ("ds-store-lib" . #s((sc-pkg-info pkg-info 3) (catalog "ds-store-lib") "2b24ac817ba86caebc3ed4826cfc5d4b4e13040f" #t "ds-store")) ("dynext-lib" . #s(pkg-info (catalog "dynext-lib") "ef6c3679a370e7ccbbc4e05c303d6dfe8cad1e79" #t)) ("eli-tester" . #s(pkg-info (catalog "eli-tester") "fbf8df6c71f4080932b4485b4c2b9a447b1d468a" #t)) ("eopl" . #s((sc-pkg-info pkg-info 3) (catalog "eopl") "88e1b01144cf4b9b96311b42ca89093b9f5b11dd" #t "eopl")) ("errortrace" . #s(pkg-info (catalog "errortrace") "ea2d92c7e6f3f0425449f498d5ff4ddf987c0eba" #t)) ("errortrace-doc" . #s(pkg-info (catalog "errortrace-doc") "3bf67f33f37880189d98b60d49c2acdc1b426447" #t)) ("errortrace-lib" . #s(pkg-info (catalog "errortrace-lib") "8ab957b4112f4f1860063e6f7f82187ba7004ad9" #t)) ("frtime" . #s((sc-pkg-info pkg-info 3) (catalog "frtime") "c156f4d7fac626f4aadc68b7f7e59827883f71cc" #t "frtime")) ("future-visualizer" . #s(pkg-info (catalog "future-visualizer") "800f8ac309181f63d9a90709f4d360e85ccc8981" #t)) ("future-visualizer-typed" . #s(pkg-info (catalog "future-visualizer-typed") "2f49eaf938a93a37e6108204275974c0db46cc5d" #t)) ("games" . #s((sc-pkg-info pkg-info 3) (catalog "games") "600cb22f1aef81cf2723e0c08650cbfc0f571fa3" #t "games")) ("gui" . #s(pkg-info (catalog "gui") "44093de5b6b7540615e230ffaeead4428f6a2924" #t)) ("gui-doc" . #s(pkg-info (catalog "gui-doc") "312899a6a8bf6a1728f21ec4f4cfd596d812dbd7" #t)) ("gui-lib" . #s(pkg-info (catalog "gui-lib") "33a6592d0078283fe463406a277b03c278a1004b" #t)) ("gui-pkg-manager-lib" . #s(pkg-info (catalog "gui-pkg-manager-lib") "0eacf8f041e668439ea4ebaf1a5ac17a2d727374" #t)) ("htdp" . #s(pkg-info (catalog "htdp") "c64660b9513a013d6d37ca24c14c0613d452ef61" #t)) ("htdp-doc" . #s(pkg-info (catalog "htdp-doc") "018aa935ac4688e20e768012a5ebbf4df926329a" #t)) ("htdp-lib" . #s(pkg-info (catalog "htdp-lib") "bee28da51a329762e9128f50da38fdbc8dbb0476" #t)) ("html" . #s(pkg-info (catalog "html") "59dc92c3a301848aba676146e15c0f2cd6aa38a9" #t)) ("html-doc" . #s(pkg-info (catalog "html-doc") "b654a0a3f5e38b78d3226f4000ff1f85de3eb0f6" #t)) ("html-lib" . #s(pkg-info (catalog "html-lib") "9050e4524334429cf2ec3bf9995ebce270941154" #t)) ("icons" . #s((sc-pkg-info pkg-info 3) (catalog "icons") "eeb4e49de168865c03b4351a907425f9c1e39078" #t "icons")) ("images" . #s(pkg-info (catalog "images") "c0ddbc44a9760aff9cd1ade13d9fa364ae71c896" #t)) ("images-doc" . #s(pkg-info (catalog "images-doc") "57bd684325371a0cd5892f7f153abd1d88383aa1" #t)) ("images-gui-lib" . #s(pkg-info (catalog "images-gui-lib") "aa9bd3460b81ce9186289f26dd6328ee48f97601" #t)) ("images-lib" . #s(pkg-info (catalog "images-lib") "c62337be2226a3a8d8b8196154b112da57a91fa7" #t)) ("lazy" . #s((sc-pkg-info pkg-info 3) (catalog "lazy") "7660e1e77bdb63416ef94b902df40b5d82c67387" #t "lazy")) ("macro-debugger" . #s(pkg-info (catalog "macro-debugger") "f6989b65c75811ab3a6435037eaffe96b71114a2" #t)) ("macro-debugger-text-lib" . #s(pkg-info (catalog "macro-debugger-text-lib") "6a4018450a1ba6aebab54c2d3f78063f21c9ce07" #t)) ("main-distribution" . #s(pkg-info (catalog "main-distribution") "4d09880d797bd4f1b69ea043ac228f27806540d9" #f)) ("make" . #s((sc-pkg-info pkg-info 3) (catalog "make") "a1aa7d92639a5990ccba1824b0cd2b4f1659653f" #t "make")) ("math" . #s(pkg-info (catalog "math") "29e118367f13d86932fc7c3193863545dcd5ade0" #t)) ("math-doc" . #s(pkg-info (catalog "math-doc") "d0a27803b7df926badd94b2fac6001ce267b1374" #t)) ("math-lib" . #s(pkg-info (catalog "math-lib") "fc7c7d42f6397ae9fb0b46565fdfdc94e1ee000f" #t)) ("mysterx" . #s((sc-pkg-info pkg-info 3) (catalog "mysterx") "c80e39384b017bbb8ba6078c212d20b53427d553" #t "mysterx")) ("mzcom" . #s((sc-pkg-info pkg-info 3) (catalog "mzcom") "f63616f5cbd4d52a4488f42dc88c0afd15a53f41" #t "mzcom")) ("mzscheme" . #s(pkg-info (catalog "mzscheme") "c29755337ea5b41d363b7b0dab97a5b6ad4623fb" #t)) ("mzscheme-doc" . #s(pkg-info (catalog "mzscheme-doc") "1a5787ba3851173354880412cf7db0fb8b539177" #t)) ("mzscheme-lib" . #s(pkg-info (catalog "mzscheme-lib") "147295fb618de988d3cfbf02ba5d155119203d35" #t)) ("net" . #s(pkg-info (catalog "net") "305df93eaee9f37021321c6559857381d90ddf8f" #t)) ("net-cookies" . #s(pkg-info (catalog "net-cookies") "37fdf96cc17bdc71ba97c30f53451d12831b996d" #t)) ("net-cookies-doc" . #s(pkg-info (catalog "net-cookies-doc") "9d60d69283b0cf1fab89046b495fb3ede7bc7c35" #t)) ("net-cookies-lib" . #s(pkg-info (catalog "net-cookies-lib") "cfc340ff7565704a17e0a4aabe7b45c963272e61" #t)) ("net-doc" . #s(pkg-info (catalog "net-doc") "a0e46b75bb480dfe18100ed79e43848c02b4afbc" #t)) ("net-lib" . #s(pkg-info (catalog "net-lib") "9f0ab82754cb36ed44f19bef8f70bb231025d3cc" #t)) ("optimization-coach" . #s(pkg-info (catalog "optimization-coach") "af6d98c959796dab585c0f2ae50b12a8b05a014a" #t)) ("option-contract" . #s(pkg-info (catalog "option-contract") "28f07dc6775defc535354fa85186438c6508efb1" #t)) ("option-contract-doc" . #s(pkg-info (catalog "option-contract-doc") "320ae5715648ae1926f9d0c89c3133fd7c1f01fc" #t)) ("option-contract-lib" . #s(pkg-info (catalog "option-contract-lib") "fa72efcee2df86c26868ce892d64a46223a4600b" #t)) ("parser-tools" . #s(pkg-info (catalog "parser-tools") "9e2986821afdab92acdb99c3c2d7b13ab8d4ba73" #t)) ("parser-tools-doc" . #s(pkg-info (catalog "parser-tools-doc") "afc80b25e0313dd95412252e46735d23b7564ad2" #t)) ("parser-tools-lib" . #s(pkg-info (catalog "parser-tools-lib") "d553885950a02faad1791223464192aac3891727" #t)) ("pconvert-lib" . #s(pkg-info (catalog "pconvert-lib") "6b506420a43d764e3bd47723481a19c56be45d72" #t)) ("pict" . #s(pkg-info (catalog "pict") "d68972270bfa859e5b9d8875d58f3ce5ccbb8cce" #t)) ("pict-doc" . #s(pkg-info (catalog "pict-doc") "051bf940662f3575a5070c20314a3c0a61ca6b47" #t)) ("pict-lib" . #s(pkg-info (catalog "pict-lib") "f74d69145b3b36e092fdaeb295a3775c104fcf21" #t)) ("pict-snip" . #s(pkg-info (catalog "pict-snip") "a51734bfa97c4d4052d099805d269fa90ee547a9" #t)) ("pict-snip-doc" . #s(pkg-info (catalog "pict-snip-doc") "9efa5a12911998d3e7670e18ef32040bfe5095ed" #t)) ("pict-snip-lib" . #s(pkg-info (catalog "pict-snip-lib") "d05571ec3cdc9a70e7026c15b550c64a3b1235e5" #t)) ("picturing-programs" . #s(pkg-info (catalog "picturing-programs") "b354c334f1a9f1ece7d35c3956f38c633ed14e12" #t)) ("plai" . #s(pkg-info (catalog "plai") "1bfa1d3d4621b01c5a8e88f977647a9264333c6b" #t)) ("plai-doc" . #s((sc-pkg-info pkg-info 3) (catalog "plai-doc") "da815d49fec3c9dc208383588405450095d15bab" #t "plai")) ("plai-lib" . #s((sc-pkg-info pkg-info 3) (catalog "plai-lib") "c752850c76d5a4de45317c1600fe08ce0a3d96b1" #t "plai")) ("planet" . #s(pkg-info (catalog "planet") "dc7473a802e717884ced2b3066bd58c20056caee" #t)) ("planet-doc" . #s(pkg-info (catalog "planet-doc") "3c627cecbacd3c61ff79991701bae619c7090e05" #t)) ("planet-lib" . #s(pkg-info (catalog "planet-lib") "b8b1be87b327808465e810110257936a146102fb" #t)) ("plot" . #s(pkg-info (catalog "plot") "e00f63e459ba02b5661190914468aa7b3ae8b3e9" #t)) ("plot-compat" . #s(pkg-info (catalog "plot-compat") "bb92420ad3abcdec6970510c00858556e35ba2dc" #t)) ("plot-doc" . #s(pkg-info (catalog "plot-doc") "2959e650538e90dce5ce328a1acd463c9bbbad61" #t)) ("plot-gui-lib" . #s(pkg-info (catalog "plot-gui-lib") "4c348a296e52f2c8d3c1c5ff2a73feef92af20d0" #t)) ("plot-lib" . #s(pkg-info (catalog "plot-lib") "92cf5468cbd071af0cff281e39444e72f207c529" #t)) ("preprocessor" . #s((sc-pkg-info pkg-info 3) (catalog "preprocessor") "74fbded09a09783f84f26959fa485a3102f7fe35" #t "preprocessor")) ("profile" . #s(pkg-info (catalog "profile") "2439446b2cde4e37d9bd3c9ea84dd92451e770df" #t)) ("profile-doc" . #s(pkg-info (catalog "profile-doc") "7be74567cb2fdab87713902b4ceb0708ff8433a7" #t)) ("profile-lib" . #s((sc-pkg-info pkg-info 3) (catalog "profile-lib") "1ac80e8887779156a26404d09d1994a50fca5c2e" #t "profile")) ("quickscript" . #s((sc-pkg-info pkg-info 3) (catalog "quickscript") "ea7c3111a714a1ec9f57b569c50067d56a7459a2" #t "quickscript")) ("r5rs" . #s(pkg-info (catalog "r5rs") "e169e377b48aecfe851890da9e0ae9f5147eb373" #t)) ("r5rs-doc" . #s(pkg-info (catalog "r5rs-doc") "9572a7bb47f8d90cf827d593aee38c3f493b7461" #t)) ("r5rs-lib" . #s(pkg-info (catalog "r5rs-lib") "9e91d2ffe91f285ae4e2f997c3efecdae513eef1" #t)) ("r6rs" . #s(pkg-info (catalog "r6rs") "5e0b6075e802464cea656dcf0205591c372097dc" #t)) ("r6rs-doc" . #s(pkg-info (catalog "r6rs-doc") "a694bbab0f1511afa9491bc70cffc0d810404835" #t)) ("r6rs-lib" . #s(pkg-info (catalog "r6rs-lib") "f7f2b9a6797648b62867bb892c9a70693c69d226" #t)) ("racket-cheat" . #s((sc-pkg-info pkg-info 3) (catalog "racket-cheat") "3f3fb93ba20d4bd7627178e51679fc216ecda979" #t "racket-cheat")) ("racket-doc" . #s(pkg-info (catalog "racket-doc") "0c46cf34e5933059bb12e771f6258931926f3337" #t)) ("racket-index" . #s(pkg-info (catalog "racket-index") "4bc153c2666643a232289b5f806cfe025ca73da5" #t)) ("racket-lib" . #s(pkg-info (catalog "racket-lib") "368ea6923f22d9a5f45d6ba5762a9284231d3a26" #f)) ("racklog" . #s((sc-pkg-info pkg-info 3) (catalog "racklog") "910abb1f5682830aa91e0dca74ceeac2c99328fb" #t "racklog")) ("rackunit" . #s(pkg-info (catalog "rackunit") "d5c38f0079c397f518b73998abf12d532dc581ac" #t)) ("rackunit-doc" . #s(pkg-info (catalog "rackunit-doc") "c13942e42f805e88bc18612a62e63787aa1dec52" #t)) ("rackunit-gui" . #s(pkg-info (catalog "rackunit-gui") "cea9f0ec960bca7b389241c9e64deb35467564d3" #t)) ("rackunit-lib" . #s(pkg-info (catalog "rackunit-lib") "0490579015cf6d050e928d7065ba6d336a87cfcb" #t)) ("rackunit-plugin-lib" . #s(pkg-info (catalog "rackunit-plugin-lib") "f49c4fcde92bb1449dd8b189778d2bdde62d4d58" #t)) ("rackunit-typed" . #s((sc-pkg-info pkg-info 3) (catalog "rackunit-typed") "ef6c7db2666bc0baf6a8c721c53bccef2f28f5ba" #t "typed")) ("readline" . #s(pkg-info (catalog "readline") "ffa26cd69c9cb2fc283607a4fe93a3bcef5e794a" #t)) ("readline-doc" . #s(pkg-info (catalog "readline-doc") "535f190905e1a2fd4a305a891c7fa3f9d1e8c6d8" #t)) ("readline-lib" . #s(pkg-info (catalog "readline-lib") "996b83e3be7e6e52e42b93b279fe87d0a2e03e8f" #t)) ("realm" . #s((sc-pkg-info pkg-info 3) (catalog "realm") "f3a918ca8d3325e9d33a41a2b16a67cee2f11040" #t "realm")) ("redex" . #s(pkg-info (catalog "redex") "c46896732085530f46d2252c11d804305fda59d0" #t)) ("redex-benchmark" . #s(pkg-info (catalog "redex-benchmark") "7eedfd1f8ea7efc0a116e3a2132b3dd1445ae706" #t)) ("redex-doc" . #s(pkg-info (catalog "redex-doc") "6e9754641d693bbdb2e698773e08ed9d5b00e81b" #t)) ("redex-examples" . #s(pkg-info (catalog "redex-examples") "6999d735acff19fae2522462c070ce3e38c39be5" #t)) ("redex-gui-lib" . #s(pkg-info (catalog "redex-gui-lib") "784b5d7acce8fdd9cd8f99d1f225a8f3098c4daa" #t)) ("redex-lib" . #s(pkg-info (catalog "redex-lib") "0a0acc5b67d6db9bcb8cd46e14dd6556fe65b9b1" #t)) ("redex-pict-lib" . #s(pkg-info (catalog "redex-pict-lib") "2bbd7523ef036701d523606b18c70a029d8e0ce7" #t)) ("sandbox-lib" . #s(pkg-info (catalog "sandbox-lib") "5e1ec0d9c2ca9303463b6fdb275715ca18bbc532" #t)) ("sasl" . #s((sc-pkg-info pkg-info 3) (catalog "sasl") "9dc01d162929f57e0507d24cbb8c2620fa635c3f" #t "sasl")) ("sasl-doc" . #s((sc-pkg-info pkg-info 3) (catalog "sasl-doc") "9b9e5cf26fc22a6a1dfcebeec40f4642a542134e" #t "sasl")) ("sasl-lib" . #s((sc-pkg-info pkg-info 3) (catalog "sasl-lib") "838eeef99f15c6e842f49d8b0a355b3bc619ce37" #t "sasl")) ("scheme-lib" . #s(pkg-info (catalog "scheme-lib") "742d3f2f1df0f0659a3cae395e07dac74c010c25" #t)) ("schemeunit" . #s((sc-pkg-info pkg-info 3) (catalog "schemeunit") "9b4d0faa18bf1e19eb3a6d2304f1df51ec6c014e" #t "schemeunit")) ("scribble" . #s(pkg-info (catalog "scribble") "94a5517b8da3160993ad2881f3623b83565488a2" #t)) ("scribble-doc" . #s(pkg-info (catalog "scribble-doc") "b5a58e7e5f8b31769b2f689ef8b5ed9b6ab32e1c" #t)) ("scribble-html-lib" . #s(pkg-info (catalog "scribble-html-lib") "996f99e3b72485d28322260bd6d46ef8e734a887" #t)) ("scribble-lib" . #s(pkg-info (catalog "scribble-lib") "e793baf76c136c13f74a68a4856de37088244198" #t)) ("scribble-text-lib" . #s(pkg-info (catalog "scribble-text-lib") "4eac00e3186362f4d82f0be3767427e9e81134c4" #t)) ("serialize-cstruct-lib" . #s(pkg-info (catalog "serialize-cstruct-lib") "80b9a9154d8bdc4733026195790b1f98ad1c40a6" #t)) ("sgl" . #s((sc-pkg-info pkg-info 3) (catalog "sgl") "fe90b545bd3c78f370ad3640ceb9789577c9d0c8" #t "sgl")) ("shell-completion" . #s((sc-pkg-info pkg-info 3) (catalog "shell-completion") "72005889b82bdbc29a4ec916a181252d510bc491" #t "shell-completion")) ("slatex" . #s((sc-pkg-info pkg-info 3) (catalog "slatex") "b7ef746195027310345543c7395a575d7c4ded6a" #t "slatex")) ("slideshow" . #s(pkg-info (catalog "slideshow") "1a03243e04425da89508cb598ae5a9184faba58a" #t)) ("slideshow-doc" . #s(pkg-info (catalog "slideshow-doc") "075dd70445da81565f422bdad13f479ded7fedf1" #t)) ("slideshow-exe" . #s(pkg-info (catalog "slideshow-exe") "b1015af465b66018b36df627a1cd68c3ac62e44f" #t)) ("slideshow-lib" . #s(pkg-info (catalog "slideshow-lib") "fc69192c5a3d0eb58358e5ab5d98c37dfc699213" #t)) ("slideshow-plugin" . #s(pkg-info (catalog "slideshow-plugin") "ffdbd7ec7c22760c7fe487402b87f7f0d359034e" #t)) ("snip" . #s(pkg-info (catalog "snip") "b45335a2bed6f78ac43881edf121d27f8e4b1e45" #t)) ("snip-lib" . #s(pkg-info (catalog "snip-lib") "525434155b94fa830b117ad77b5d373db74cdad6" #t)) ("source-syntax" . #s((sc-pkg-info pkg-info 3) (catalog "source-syntax") "736996db33a9c9ab6597e1f4fd08d76f8f488aa2" #t "syntax")) ("srfi" . #s(pkg-info (catalog "srfi") "63dca22aaab8699aaeb1f8d383a19952fb22de8d" #t)) ("srfi-doc" . #s(pkg-info (catalog "srfi-doc") "e785b773dcdff063a22ce37702e61eb90876708a" #t)) ("srfi-doc-nonfree" . #s(pkg-info (catalog "srfi-doc-nonfree") "0b8d31d6107324c25c8dba2632741c3dac497318" #t)) ("srfi-lib" . #s(pkg-info (catalog "srfi-lib") "c91ba54b8388481603624061df5d057e7c04bd23" #t)) ("srfi-lib-nonfree" . #s(pkg-info (catalog "srfi-lib-nonfree") "33e6b1b3dbf5acde1dff7391a1f9c69c4817371b" #t)) ("srfi-lite-lib" . #s(pkg-info (catalog "srfi-lite-lib") "2849cb93557ad09f6283762024eb72eb5c753477" #t)) ("string-constants" . #s(pkg-info (catalog "string-constants") "cc980dcabf6d8c7eaf1f054c7e17efac7df1ec67" #t)) ("string-constants-doc" . #s(pkg-info (catalog "string-constants-doc") "b0167d272ae4920287be161956992397af0d5f60" #t)) ("string-constants-lib" . #s(pkg-info (catalog "string-constants-lib") "356bc815c1d1221b2cceb21deae6ac6f720cf23d" #t)) ("swindle" . #s((sc-pkg-info pkg-info 3) (catalog "swindle") "fa98a87f1898e373d8e0ec4a8ce446d7e437e789" #t "swindle")) ("syntax-color" . #s(pkg-info (catalog "syntax-color") "72eff871b5f762ff72210a68fec4ad1e93c2cdaa" #t)) ("syntax-color-doc" . #s(pkg-info (catalog "syntax-color-doc") "437e442d61bc51e1e3dd7534465011e698778f96" #t)) ("syntax-color-lib" . #s(pkg-info (catalog "syntax-color-lib") "3b5cd8d5f5a2cc7c6132980e9ac064e583ca65d2" #t)) ("testing-util-lib" . #s(pkg-info (catalog "testing-util-lib") "21c04c13231c4dd86cef3baa86c0617cdbdde656" #t)) ("tex-table" . #s((sc-pkg-info pkg-info 3) (catalog "tex-table") "15efd44bf0e78f4c40af98a8008a5bc090e6f637" #t "mrlib")) ("trace" . #s((sc-pkg-info pkg-info 3) (catalog "trace") "7a796718a63e519c202084db60720f559ae4f31b" #t "trace")) ("typed-racket" . #s(pkg-info (catalog "typed-racket") "3a61a4a96e0296cf50465423eb8756a36733ed9d" #t)) ("typed-racket-compatibility" . #s(pkg-info (catalog "typed-racket-compatibility") "e0e18958fc913182993ae099c96d778e86a4f939" #t)) ("typed-racket-doc" . #s(pkg-info (catalog "typed-racket-doc") "eb7e366ce9fb7d7ec63dc277d653d19d7765acd8" #t)) ("typed-racket-lib" . #s(pkg-info (catalog "typed-racket-lib") "867db3bde6e00cae4b7735b7eaa2ad585ef8247b" #t)) ("typed-racket-more" . #s(pkg-info (catalog "typed-racket-more") "655515f68bb21caeaaab474da55b6c9ee011d522" #t)) ("unix-socket" . #s(pkg-info (catalog "unix-socket") "98a0d29889301a8fb9a6580702d6ed1ab9eb1fe7" #t)) ("unix-socket-doc" . #s(pkg-info (catalog "unix-socket-doc") "ea521fdf0c1fdb2f261ad515da120271240dfddf" #t)) ("unix-socket-lib" . #s(pkg-info (catalog "unix-socket-lib") "50f655e24079d4d6845dcddd2d22e5db2148a57e" #t)) ("web-server" . #s(pkg-info (catalog "web-server") "21c4b915b19ea0233de8f13bacd22637c5aa00ab" #t)) ("web-server-doc" . #s(pkg-info (catalog "web-server-doc") "23fd20ddd44f5a8b57cc0535cab12c8f163146f4" #t)) ("web-server-lib" . #s(pkg-info (catalog "web-server-lib") "002063b1609ea4b0da3746241eaaa2c33c6d5181" #t)) ("wxme" . #s(pkg-info (catalog "wxme") "1e2f7aadc54188445684d5ec668d1a8b8feee2d1" #t)) ("wxme-lib" . #s(pkg-info (catalog "wxme-lib") "01b3ca68df92d39739fcb18eb5a0f947fad61f79" #t)) ("xrepl" . #s(pkg-info (catalog "xrepl") "8749484d6cedecbfb33b70fb66b8993fa019954e" #t)) ("xrepl-doc" . #s(pkg-info (catalog "xrepl-doc") "f2eb9a2642c9b5214944ccb9fbb339630025d2f9" #t)) ("xrepl-lib" . #s(pkg-info (catalog "xrepl-lib") "e6d3de63ebcbf1ed1d09981779a6d36d0041daa4" #t)) ("zo-lib" . #s(pkg-info (catalog "zo-lib") "7fc95552ca466bf7354b78ec3a1904c4f00c7c1b" #t))) +#hash(("2d" . #s(pkg-info (catalog "2d") "b9ec16b7c3913d4e3b82ee0b195ff39c21c964f8" #t)) ("2d-doc" . #s((sc-pkg-info pkg-info 3) (catalog "2d-doc") "0f29958e0b65c3cc5e334eec20bc329b4505543a" #t "2d")) ("2d-lib" . #s((sc-pkg-info pkg-info 3) (catalog "2d-lib") "1a0eca919acda056cc0fdb627ed856e474c7de96" #t "2d")) ("algol60" . #s((sc-pkg-info pkg-info 3) (catalog "algol60") "2263a6169235747a71b1e3c841345bb53673e4d5" #t "algol60")) ("at-exp-lib" . #s(pkg-info (catalog "at-exp-lib") "984827641d4c54a807ef05591fa095f01fc39db0" #t)) ("base" . #s(pkg-info (catalog "base") "3b73f30fc6355d09c5db9a67353328594bef27bd" #t)) ("cext-lib" . #s(pkg-info (catalog "cext-lib") "93ed980ae7f785ca2b85279101f162106dcf0891" #t)) ("class-iop-lib" . #s(pkg-info (catalog "class-iop-lib") "d9a209d2b0135b3d6a04bce5b5216901f6308572" #t)) ("compatibility" . #s(pkg-info (catalog "compatibility") "c0269f219b2affb5ce3e6a22be54bb45beeeab0b" #t)) ("compatibility-doc" . #s(pkg-info (catalog "compatibility-doc") "8fe78c3df4d4473b500c958982841618d65bfa0a" #t)) ("compatibility-lib" . #s(pkg-info (catalog "compatibility-lib") "ec1058be5748693364ebe84137105d356fed1592" #t)) ("compiler" . #s(pkg-info (catalog "compiler") "ddea1ba3be18d58acb2ca306f1592f46e314df28" #t)) ("compiler-lib" . #s(pkg-info (catalog "compiler-lib") "e01ce63b08ade97db09738bf23cf9395579e7a0a" #t)) ("contract-profile" . #s((sc-pkg-info pkg-info 3) (catalog "contract-profile") "958557bdfdd2a5514c44205abb7e7a70f0b2d279" #t "contract-profile")) ("data" . #s(pkg-info (catalog "data") "6ac1f7a70e74dea4fa82e33288605ce7d56456f0" #t)) ("data-doc" . #s(pkg-info (catalog "data-doc") "6565845ac378a2ee624027d58ba666c919a5b489" #t)) ("data-enumerate-lib" . #s(pkg-info (catalog "data-enumerate-lib") "1cbe60b74c1824413ad812383eed9ea0e8010526" #t)) ("data-lib" . #s(pkg-info (catalog "data-lib") "d4e455aefd23cdb9025f30ec7b4884e807ef2f77" #t)) ("datalog" . #s((sc-pkg-info pkg-info 3) (catalog "datalog") "eeb3e053c3162c201e65e0eba678b593d89ac34c" #t "datalog")) ("db" . #s(pkg-info (catalog "db") "b8ffce179e3c102f16863cd5ac85638c540293a3" #t)) ("db-doc" . #s(pkg-info (catalog "db-doc") "ed7638979ffddc3f87b7fa0263b102db5d67f8a2" #t)) ("db-lib" . #s(pkg-info (catalog "db-lib") "7662bcfc574d0f592e699d5ec963386fb30b8e75" #t)) ("deinprogramm" . #s(pkg-info (catalog "deinprogramm") "220869082b9a378441ea5329a8fabf5334463dff" #t)) ("deinprogramm-signature" . #s(pkg-info (catalog "deinprogramm-signature") "90a2daf0a1d825346113b9365a2aa245c195815b" #t)) ("distributed-places" . #s(pkg-info (catalog "distributed-places") "36f5692b69419a2d518e82bb642b6960b08b7fa5" #t)) ("distributed-places-doc" . #s(pkg-info (catalog "distributed-places-doc") "e92b8674daefac9b2038a8e88c441e068819c5ea" #t)) ("distributed-places-lib" . #s(pkg-info (catalog "distributed-places-lib") "f494d5ed984396d1397b4458db0eb8aec829a51c" #t)) ("draw" . #s(pkg-info (catalog "draw") "1f642fa369343b9bab49eb22b89e96354402f560" #t)) ("draw-doc" . #s(pkg-info (catalog "draw-doc") "7daf97bea729efd0f1da0e81e69e64dcb350aacc" #t)) ("draw-lib" . #s(pkg-info (catalog "draw-lib") "64b7c6f6827467345b62b7f74d815e526b0dff2f" #t)) ("drracket" . #s(pkg-info (catalog "drracket") "450d8b855c8c4bef29a3e7614fd831d53255bbac" #t)) ("drracket-plugin-lib" . #s(pkg-info (catalog "drracket-plugin-lib") "b3433d04fa131dfd647b759a39f68737e1744c42" #t)) ("drracket-tool" . #s(pkg-info (catalog "drracket-tool") "ee61e0b1494330217591635acbd2397f7d654542" #t)) ("drracket-tool-doc" . #s(pkg-info (catalog "drracket-tool-doc") "5ce79d17d39a68eff6d5aa2c7b2c546ef20a8162" #t)) ("drracket-tool-lib" . #s(pkg-info (catalog "drracket-tool-lib") "507f09bef34222ce4a191b03841d7f8d13e81d6c" #t)) ("ds-store" . #s((sc-pkg-info pkg-info 3) (catalog "ds-store") "d01a2404fcfd35ff4f7ae1111cc7306bfbc524ee" #t "ds-store")) ("ds-store-doc" . #s((sc-pkg-info pkg-info 3) (catalog "ds-store-doc") "3512350cd870082334a54c469fc00d709a33793b" #t "ds-store")) ("ds-store-lib" . #s((sc-pkg-info pkg-info 3) (catalog "ds-store-lib") "3fc255f865837fb53912513ae9e68ecd9108596b" #t "ds-store")) ("dynext-lib" . #s(pkg-info (catalog "dynext-lib") "b8d1518ae8f50ed38d660e5c7c6682cc1b073b68" #t)) ("eli-tester" . #s(pkg-info (catalog "eli-tester") "72f75bdc43c0a89ceb6ccfef0080bc9d4e592226" #t)) ("eopl" . #s((sc-pkg-info pkg-info 3) (catalog "eopl") "bf0382b52f2ea12c15805d4c2f9b9f1f124ac9c8" #t "eopl")) ("errortrace" . #s(pkg-info (catalog "errortrace") "facedbeb581ced6930e0d41309b56150d350ecb2" #t)) ("errortrace-doc" . #s(pkg-info (catalog "errortrace-doc") "2da65b2627d987d380a7c0390026832b316c512e" #t)) ("errortrace-lib" . #s(pkg-info (catalog "errortrace-lib") "2587f66d8abe4a02f2f067171463f97157f99964" #t)) ("frtime" . #s((sc-pkg-info pkg-info 3) (catalog "frtime") "53545bf337589f109223055d4a83216b627e059c" #t "frtime")) ("future-visualizer" . #s(pkg-info (catalog "future-visualizer") "d59d2d32c9ed2ad1e10f012aa1b804a035271704" #t)) ("future-visualizer-typed" . #s(pkg-info (catalog "future-visualizer-typed") "828433640a58588228d9bd13f6b3de550465bb0c" #t)) ("games" . #s((sc-pkg-info pkg-info 3) (catalog "games") "af59d3a4923906472ec988bd51ce9ab818e31ee1" #t "games")) ("gui" . #s(pkg-info (catalog "gui") "6f5376993deb061a9aa3f8357b71d0fff12606bd" #t)) ("gui-doc" . #s(pkg-info (catalog "gui-doc") "580a9960ff3a58391e79a8a462957570be6bd987" #t)) ("gui-lib" . #s(pkg-info (catalog "gui-lib") "1524eab39203386d0159eea8d55427d03e188f93" #t)) ("gui-pkg-manager-lib" . #s(pkg-info (catalog "gui-pkg-manager-lib") "31b71b7e18430a75782777289323ef9ecbb3c903" #t)) ("htdp" . #s(pkg-info (catalog "htdp") "0caf5122536fa19539f38e42bd37085c7c5e1a8f" #t)) ("htdp-doc" . #s(pkg-info (catalog "htdp-doc") "5cddbdde6de3139305b6bbc718c2fa87bde045e9" #t)) ("htdp-lib" . #s(pkg-info (catalog "htdp-lib") "5faec4edbff59c23b63ac36122d1f54c56ea2156" #t)) ("html" . #s(pkg-info (catalog "html") "01d2be91bfc780abaa43eafedee4836535b9b1e0" #t)) ("html-doc" . #s(pkg-info (catalog "html-doc") "5e37e51cb4eb9eaed3eca3ae605a21a66c506e58" #t)) ("html-lib" . #s(pkg-info (catalog "html-lib") "51ee8bc39f47e32678a2bdefb74ac1b397fa58af" #t)) ("icons" . #s((sc-pkg-info pkg-info 3) (catalog "icons") "d79b5bb1230311753dbb7d789656890925ba1368" #t "icons")) ("images" . #s(pkg-info (catalog "images") "c07643a053a11b27dba3b442017b8b352139cce3" #t)) ("images-doc" . #s(pkg-info (catalog "images-doc") "44bda07c46a2af9248ea3cac7ba9b6a1a7a18d36" #t)) ("images-gui-lib" . #s(pkg-info (catalog "images-gui-lib") "5de815be6817366d7efe0a3251a354d1da4cd333" #t)) ("images-lib" . #s(pkg-info (catalog "images-lib") "6243f13e71ecb77a0480ea18d4c5f347289ccb56" #t)) ("lazy" . #s((sc-pkg-info pkg-info 3) (catalog "lazy") "8185380fb9a22aca5f30298981d50245ff77ab8b" #t "lazy")) ("macro-debugger" . #s(pkg-info (catalog "macro-debugger") "9cfa6e57cca35ba79d99fb6cb407ebf6011b8a88" #t)) ("macro-debugger-text-lib" . #s(pkg-info (catalog "macro-debugger-text-lib") "17a42f809889d95d2e657f21812b1ee9a9668ad8" #t)) ("main-distribution" . #s(pkg-info (catalog "main-distribution") "c1122917ba1e292ab1465335f19199f2cc432b3d" #f)) ("make" . #s((sc-pkg-info pkg-info 3) (catalog "make") "d570b45aca78a1b99eb655d604878cf19293416d" #t "make")) ("math" . #s(pkg-info (catalog "math") "336c086b5a568ff8b8044445111b6007b1cee0fb" #t)) ("math-doc" . #s(pkg-info (catalog "math-doc") "5d0d081f561633298202b24b3e523066f2fb70db" #t)) ("math-lib" . #s(pkg-info (catalog "math-lib") "43ea67424046fcebbf1229d25a66f2e199784277" #t)) ("mysterx" . #s((sc-pkg-info pkg-info 3) (catalog "mysterx") "ad44758e6005d0dbbf4832fb7b0e96a1efe7a4af" #t "mysterx")) ("mzcom" . #s((sc-pkg-info pkg-info 3) (catalog "mzcom") "cedc397df62f7b1ab8d76c4bc50a630cf17cb0b8" #t "mzcom")) ("mzscheme" . #s(pkg-info (catalog "mzscheme") "9bc135d52cc64d7e2654331351c9c85c44f19293" #t)) ("mzscheme-doc" . #s(pkg-info (catalog "mzscheme-doc") "83981e83f20d22ed86d5045f57ae3dbbfa535ab4" #t)) ("mzscheme-lib" . #s(pkg-info (catalog "mzscheme-lib") "af17be4f3304b4631e7cf5e7babe41a70844f4e6" #t)) ("net" . #s(pkg-info (catalog "net") "fcca9df2182a65673fd5d7d1fb7a24123ce97c20" #t)) ("net-cookies" . #s(pkg-info (catalog "net-cookies") "004cd78c5355ccfd565963d2c0ff57ecc7cd0c60" #t)) ("net-cookies-doc" . #s(pkg-info (catalog "net-cookies-doc") "4f242a6a3c43b5f1996e744f0a8e0d8d483092af" #t)) ("net-cookies-lib" . #s(pkg-info (catalog "net-cookies-lib") "a430008e911082d740a494997e97a23dc8ef4f9c" #t)) ("net-doc" . #s(pkg-info (catalog "net-doc") "e637419fe009b8f5f93d5d3e96e4e251505c5067" #t)) ("net-lib" . #s(pkg-info (catalog "net-lib") "746f3befbf23646fa5f5ad7d48a94c9f8b36d0c7" #t)) ("optimization-coach" . #s(pkg-info (catalog "optimization-coach") "e6a6b0b180543159ca7ff690a68ff8b279573179" #t)) ("option-contract" . #s(pkg-info (catalog "option-contract") "22e3b7856a1cc4f8c016a6a0a6fa8caaa48d37de" #t)) ("option-contract-doc" . #s(pkg-info (catalog "option-contract-doc") "a3c614c4a772139806e29948848802d0915b317c" #t)) ("option-contract-lib" . #s(pkg-info (catalog "option-contract-lib") "bb18d01a71226d2e1804a7f9a9edad54625f16f7" #t)) ("parser-tools" . #s(pkg-info (catalog "parser-tools") "751a50d41e9c5b1574a6564c631da15c9d782dfa" #t)) ("parser-tools-doc" . #s(pkg-info (catalog "parser-tools-doc") "6328ba8e533ead2d937a3e4291aaad6829384c17" #t)) ("parser-tools-lib" . #s(pkg-info (catalog "parser-tools-lib") "101a88403db3dfe899259ddb626ca555891d77c7" #t)) ("pconvert-lib" . #s(pkg-info (catalog "pconvert-lib") "700aaf7e3e117c344cc63ee9d34767a707c1423a" #t)) ("pict" . #s(pkg-info (catalog "pict") "7054d26b0018318e3b66ca2898a5b8941955dc59" #t)) ("pict-doc" . #s(pkg-info (catalog "pict-doc") "bd70ed1d72d4db99e35d647c8ee60f5dc2eaa67a" #t)) ("pict-lib" . #s(pkg-info (catalog "pict-lib") "a6b81ad67889474df1745718286254f442443d84" #t)) ("pict-snip" . #s(pkg-info (catalog "pict-snip") "24d90901966e4bd05927aeb0c98d04e112c9752c" #t)) ("pict-snip-doc" . #s(pkg-info (catalog "pict-snip-doc") "b812ac3ed36771e795d1ebdbe00f13c5188310f7" #t)) ("pict-snip-lib" . #s(pkg-info (catalog "pict-snip-lib") "a4b62bfc89acc9b61761b80ee8f809f067dc65f1" #t)) ("picturing-programs" . #s(pkg-info (catalog "picturing-programs") "c49d5d540fa86c785f34cdf0e137ad2be11b7e74" #t)) ("plai" . #s(pkg-info (catalog "plai") "52d7b84c65a232310b66256db5bcb2813a861047" #t)) ("plai-doc" . #s((sc-pkg-info pkg-info 3) (catalog "plai-doc") "6797f2e34e819f55e3fca3c463fcc42727382bf3" #t "plai")) ("plai-lib" . #s((sc-pkg-info pkg-info 3) (catalog "plai-lib") "3824f69a19f128b81bbbc41b2f1f725178572bf9" #t "plai")) ("planet" . #s(pkg-info (catalog "planet") "8bc989148e2e9a46cfc05efe4582559a36de1339" #t)) ("planet-doc" . #s(pkg-info (catalog "planet-doc") "d5198f8aba89c69cd79ba16d88d9ceaba4afed58" #t)) ("planet-lib" . #s(pkg-info (catalog "planet-lib") "848590c925b061762473d5ab7785a5d6e64fba1c" #t)) ("plot" . #s(pkg-info (catalog "plot") "8f161448d136ae106c162168516927509c6189e5" #t)) ("plot-compat" . #s(pkg-info (catalog "plot-compat") "4ba4c83a5fbfcd569647c19907ec5e8e06b69901" #t)) ("plot-doc" . #s(pkg-info (catalog "plot-doc") "f349273ed1fb43457fd64bc4bc10a7ebabdfebff" #t)) ("plot-gui-lib" . #s(pkg-info (catalog "plot-gui-lib") "2efcb959d0bea10f83b0b97f2d6cd07a4a92f2be" #t)) ("plot-lib" . #s(pkg-info (catalog "plot-lib") "e3f0d865dd9d0fff5572652eea1513ade703f46b" #t)) ("preprocessor" . #s((sc-pkg-info pkg-info 3) (catalog "preprocessor") "48e9bcc9307b6e70450e2b9027eec71590213ec5" #t "preprocessor")) ("profile" . #s(pkg-info (catalog "profile") "a38dc9d0342859e96abaca079af177a2aa10a69a" #t)) ("profile-doc" . #s(pkg-info (catalog "profile-doc") "90c6620ef5dca4fcd2e8418a1ad10a21a2734f72" #t)) ("profile-lib" . #s((sc-pkg-info pkg-info 3) (catalog "profile-lib") "4e84b0ec888a547156a65eba7cb0226670ffae4c" #t "profile")) ("quickscript" . #s((sc-pkg-info pkg-info 3) (catalog "quickscript") "2719a9785ecb95035a4930620cade21650c869c4" #t "quickscript")) ("r5rs" . #s(pkg-info (catalog "r5rs") "e02c8ca8858697976ed189dc41edd74f2b5ca5ff" #t)) ("r5rs-doc" . #s(pkg-info (catalog "r5rs-doc") "b9a4548acf380eb66b49c9b21d72d79f7872a89d" #t)) ("r5rs-lib" . #s(pkg-info (catalog "r5rs-lib") "24288264d3235be106235508209275c20393d722" #t)) ("r6rs" . #s(pkg-info (catalog "r6rs") "080d4fbb7a716a052e9124ac882cea8bee8a0913" #t)) ("r6rs-doc" . #s(pkg-info (catalog "r6rs-doc") "2fcf896978f2ae9f922ecf759e6f34bca14994ef" #t)) ("r6rs-lib" . #s(pkg-info (catalog "r6rs-lib") "bfe87840d422039970f26b492f3263f3c9bfbe6f" #t)) ("racket-cheat" . #s((sc-pkg-info pkg-info 3) (catalog "racket-cheat") "ec5d08655cda0924de41f59c9da428344db36605" #t "racket-cheat")) ("racket-doc" . #s(pkg-info (catalog "racket-doc") "c80a8b3c28390ee40e3e2146c8112601a34f3952" #t)) ("racket-index" . #s(pkg-info (catalog "racket-index") "e5b7e7ce7f66a77bfbdef958021f24c3a411f0be" #t)) ("racket-lib" . #s(pkg-info (catalog "racket-lib") "3844fcf1e76ef3e5d3e7988d79a0b989af19d384" #f)) ("racklog" . #s((sc-pkg-info pkg-info 3) (catalog "racklog") "87291702c2a0329ccf7d129b1574a55d108ba350" #t "racklog")) ("rackunit" . #s(pkg-info (catalog "rackunit") "42fe247d959f2bd457eefd13373edcf1f7226864" #t)) ("rackunit-doc" . #s(pkg-info (catalog "rackunit-doc") "dc419d1ad965f49a3d3c30c25f0dd7e236d72a23" #t)) ("rackunit-gui" . #s(pkg-info (catalog "rackunit-gui") "14ad1923cd75bea71a56d57e8f239bc25a124a4c" #t)) ("rackunit-lib" . #s(pkg-info (catalog "rackunit-lib") "5c2844b6ac8d00c83431098732d189b6a4c435b1" #t)) ("rackunit-plugin-lib" . #s(pkg-info (catalog "rackunit-plugin-lib") "80be444f6624982d63ca49c36e3be46c0084a735" #t)) ("rackunit-typed" . #s((sc-pkg-info pkg-info 3) (catalog "rackunit-typed") "89720a05feb364e2aeed30c1fc43b9460e8c6f0f" #t "typed")) ("readline" . #s(pkg-info (catalog "readline") "b79faaf7604c030d1a7882cbb3311d90a5db09c4" #t)) ("readline-doc" . #s(pkg-info (catalog "readline-doc") "56d33825fedf2ef670db774e529a9718151c8614" #t)) ("readline-lib" . #s(pkg-info (catalog "readline-lib") "160fc6c2f344f2ddceec61960d17b839cc2d2d5c" #t)) ("realm" . #s((sc-pkg-info pkg-info 3) (catalog "realm") "f1dce5652ab6847f0f733ba9a805bc763af373e6" #t "realm")) ("redex" . #s(pkg-info (catalog "redex") "1f05d9a093bdda1846a46547ded17200916491b2" #t)) ("redex-benchmark" . #s(pkg-info (catalog "redex-benchmark") "c17f591504bd7bae918f980ff0d68ef52889ddaf" #t)) ("redex-doc" . #s(pkg-info (catalog "redex-doc") "eab5b812fa8379844b5173ea444c6d4ee5ffa0e2" #t)) ("redex-examples" . #s(pkg-info (catalog "redex-examples") "f723401b70d727b48a50e2f5847a277cd058dcc1" #t)) ("redex-gui-lib" . #s(pkg-info (catalog "redex-gui-lib") "9caca294028c4681a27539eee4d20a3cbefa55d6" #t)) ("redex-lib" . #s(pkg-info (catalog "redex-lib") "c420868111be236dddd6b086b644a68d006e23ff" #t)) ("redex-pict-lib" . #s(pkg-info (catalog "redex-pict-lib") "c4fd3e1d28cabac0e2c7e91e34c422137baed62e" #t)) ("sandbox-lib" . #s(pkg-info (catalog "sandbox-lib") "438111a0b68a77b207d0417d56478df8c8f3195f" #t)) ("sasl" . #s((sc-pkg-info pkg-info 3) (catalog "sasl") "2908169351c2867afa7f7748bcd7025628232baf" #t "sasl")) ("sasl-doc" . #s((sc-pkg-info pkg-info 3) (catalog "sasl-doc") "96f22d4d7297a31517c31a67f6eecd1cc17a10a1" #t "sasl")) ("sasl-lib" . #s((sc-pkg-info pkg-info 3) (catalog "sasl-lib") "2fc1d21429bc87c9c8958aa46daa3bafeeb6c30d" #t "sasl")) ("scheme-lib" . #s(pkg-info (catalog "scheme-lib") "0a3c11732e50f87cb80cecabe0383a51a087c58c" #t)) ("schemeunit" . #s((sc-pkg-info pkg-info 3) (catalog "schemeunit") "2264d8fb729ef8a81c4c49b0d249cd8307fe3337" #t "schemeunit")) ("scribble" . #s(pkg-info (catalog "scribble") "0998c9b3c5e825c9ba35af40b3d4e45e98fdb325" #t)) ("scribble-doc" . #s(pkg-info (catalog "scribble-doc") "cf29c26a0c1616a53e4c3ee64866baa36c0bc876" #t)) ("scribble-html-lib" . #s(pkg-info (catalog "scribble-html-lib") "130a4af8652a588f013bedec07d474df3d405140" #t)) ("scribble-lib" . #s(pkg-info (catalog "scribble-lib") "4a5127098d285025ba74c34adebb51bfc603daf7" #t)) ("scribble-text-lib" . #s(pkg-info (catalog "scribble-text-lib") "cd993b82b00a08c3eff3ae028670fc6a5a4e6567" #t)) ("serialize-cstruct-lib" . #s(pkg-info (catalog "serialize-cstruct-lib") "f4b839f605fdd4e1c3fac36754ab46618418723d" #t)) ("sgl" . #s((sc-pkg-info pkg-info 3) (catalog "sgl") "322ca958414b09f46c1f4487a398bc03fb9f388d" #t "sgl")) ("shell-completion" . #s((sc-pkg-info pkg-info 3) (catalog "shell-completion") "c66d49ca1f166623a2877c01f7820c7f3543743a" #t "shell-completion")) ("slatex" . #s((sc-pkg-info pkg-info 3) (catalog "slatex") "db734a9f796dcf2246c2b05e1a765f39977b637d" #t "slatex")) ("slideshow" . #s(pkg-info (catalog "slideshow") "551785d405e70ed213e335bfef946c8d59b2161a" #t)) ("slideshow-doc" . #s(pkg-info (catalog "slideshow-doc") "18d8953032e380e13fe20e5f17e68956e0728389" #t)) ("slideshow-exe" . #s(pkg-info (catalog "slideshow-exe") "60deb7fb3200be02f308d8319fa76b8fc611f1ca" #t)) ("slideshow-lib" . #s(pkg-info (catalog "slideshow-lib") "acf5bcf621df2a3a799bcedb8094031822d57ce9" #t)) ("slideshow-plugin" . #s(pkg-info (catalog "slideshow-plugin") "f5c06125918c451a94654a36a97606442f3a2be7" #t)) ("snip" . #s(pkg-info (catalog "snip") "58872a15be601c8bdd8863fcf03077406e7cceb3" #t)) ("snip-lib" . #s(pkg-info (catalog "snip-lib") "37756299d8a397fa6c0e2da5910b931bfc751a70" #t)) ("source-syntax" . #s((sc-pkg-info pkg-info 3) (catalog "source-syntax") "704186c3a3258ffed3892e145e9a4152447560b9" #t "syntax")) ("srfi" . #s(pkg-info (catalog "srfi") "2d721c054acf85ded2e832b4e769a570c5d0ef4e" #t)) ("srfi-doc" . #s(pkg-info (catalog "srfi-doc") "867bc9e68f6359e19d204878397cbc91062029f2" #t)) ("srfi-doc-nonfree" . #s(pkg-info (catalog "srfi-doc-nonfree") "e8b91a91214d5fb505f93e688741a0c65faad9f1" #t)) ("srfi-lib" . #s(pkg-info (catalog "srfi-lib") "f22a5dbc9ed12503748622bfbdd6ca93ede202d7" #t)) ("srfi-lib-nonfree" . #s(pkg-info (catalog "srfi-lib-nonfree") "85dfd2720ceb2bbb984a743b3d1e450a6b1f596c" #t)) ("srfi-lite-lib" . #s(pkg-info (catalog "srfi-lite-lib") "af3dd4c0e11b4e1eebcb9cd445ad06853d94388a" #t)) ("string-constants" . #s(pkg-info (catalog "string-constants") "19f873d6216861bea127f34773a2e534038a9953" #t)) ("string-constants-doc" . #s(pkg-info (catalog "string-constants-doc") "c889b129121efebadb5579aa4057204004df1019" #t)) ("string-constants-lib" . #s(pkg-info (catalog "string-constants-lib") "d09846af43ac4a152682006ee970f9e4f294487a" #t)) ("swindle" . #s((sc-pkg-info pkg-info 3) (catalog "swindle") "008e50f0d17375cc6b5d365edcb642cfd1c5af90" #t "swindle")) ("syntax-color" . #s(pkg-info (catalog "syntax-color") "d159c5ca130f77e650742176bb8632ffcd443394" #t)) ("syntax-color-doc" . #s(pkg-info (catalog "syntax-color-doc") "6395caa5d9752c4b00a3d7c077cf4686674fbe7e" #t)) ("syntax-color-lib" . #s(pkg-info (catalog "syntax-color-lib") "c3ee1d047b4b1c40ed471516186f27c8bba7bfb8" #t)) ("testing-util-lib" . #s(pkg-info (catalog "testing-util-lib") "4371609bae349e0a72668f63b7abbbd9337e362e" #t)) ("tex-table" . #s((sc-pkg-info pkg-info 3) (catalog "tex-table") "d51de5449ddb7bbb729136af6ac14553a466f71c" #t "mrlib")) ("trace" . #s((sc-pkg-info pkg-info 3) (catalog "trace") "48471971fb4b644d30244cf7d7c50ff1d2aa18eb" #t "trace")) ("typed-racket" . #s(pkg-info (catalog "typed-racket") "e8164171f972506b12314ff6b498f08dd49484dc" #t)) ("typed-racket-compatibility" . #s(pkg-info (catalog "typed-racket-compatibility") "111fb5dfd50f009a7ee40889f340354dec6c9636" #t)) ("typed-racket-doc" . #s(pkg-info (catalog "typed-racket-doc") "5fe67bbc4385fab6d39d1ea416c4e85b5b8a8833" #t)) ("typed-racket-lib" . #s(pkg-info (catalog "typed-racket-lib") "b170038550350bc46bf4769e363543ca16a7f8d4" #t)) ("typed-racket-more" . #s(pkg-info (catalog "typed-racket-more") "25fc40f46b6af7ee80636feb2033aedfe0e8864c" #t)) ("unix-socket" . #s(pkg-info (catalog "unix-socket") "c1f3ae1c701fff08956c6f7f0d8df7d456d926bf" #t)) ("unix-socket-doc" . #s(pkg-info (catalog "unix-socket-doc") "9534f44d8a8f8a0bd7675426716dfdcf9b13260c" #t)) ("unix-socket-lib" . #s(pkg-info (catalog "unix-socket-lib") "9c30e8a4b1090b4f6a2f13428aaa67d059557460" #t)) ("web-server" . #s(pkg-info (catalog "web-server") "c9c2e896595dfd1e656eddbdb99424925d98a950" #t)) ("web-server-doc" . #s(pkg-info (catalog "web-server-doc") "2e574c486ee8332435d01626d6e1532a5911a882" #t)) ("web-server-lib" . #s(pkg-info (catalog "web-server-lib") "9bebe1d398ed3387be91d135e8c3e147aa3d3311" #t)) ("wxme" . #s(pkg-info (catalog "wxme") "8feddc8cfb46ed3664369d29cd6f5ef3ae69d889" #t)) ("wxme-lib" . #s(pkg-info (catalog "wxme-lib") "b33f0ce99893d28de0fd6b3503de06f25fd4f7cb" #t)) ("xrepl" . #s(pkg-info (catalog "xrepl") "0f96b51cc717cfc78831d52a063541147f5cc163" #t)) ("xrepl-doc" . #s(pkg-info (catalog "xrepl-doc") "805e75dea6dd61f13096b84c9619a5e7f75d5955" #t)) ("xrepl-lib" . #s(pkg-info (catalog "xrepl-lib") "cb1de464ed1e938d3ace039db46b9412047552b8" #t)) ("zo-lib" . #s(pkg-info (catalog "zo-lib") "5d511085f69045de49254e961133b7db9247882d" #t))) diff -Nru racket-7.2+ppa2/share/pkgs/plai/info.rkt racket-7.3+ppa1/share/pkgs/plai/info.rkt --- racket-7.2+ppa2/share/pkgs/plai/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/plai/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/plai-doc/info.rkt racket-7.3+ppa1/share/pkgs/plai-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/plai-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/plai-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/plai-lib/info.rkt racket-7.3+ppa1/share/pkgs/plai-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/plai-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/plai-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/planet/info.rkt racket-7.3+ppa1/share/pkgs/planet/info.rkt --- racket-7.2+ppa2/share/pkgs/planet/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/planet/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/planet-doc/info.rkt racket-7.3+ppa1/share/pkgs/planet-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/planet-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/planet-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/planet-lib/info.rkt racket-7.3+ppa1/share/pkgs/planet-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/planet-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/planet-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/plot/info.rkt racket-7.3+ppa1/share/pkgs/plot/info.rkt --- racket-7.2+ppa2/share/pkgs/plot/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/plot/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/plot-compat/info.rkt racket-7.3+ppa1/share/pkgs/plot-compat/info.rkt --- racket-7.2+ppa2/share/pkgs/plot-compat/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/plot-compat/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/plot-doc/info.rkt racket-7.3+ppa1/share/pkgs/plot-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/plot-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/plot-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/plot-doc/plot/scribblings/common.rkt racket-7.3+ppa1/share/pkgs/plot-doc/plot/scribblings/common.rkt --- racket-7.2+ppa2/share/pkgs/plot-doc/plot/scribblings/common.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/plot-doc/plot/scribblings/common.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -42,3 +42,33 @@ (define (close-plot-eval) (close-eval plot-eval)) + +(require plot/no-gui plot/utils pict racket/match racket/class racket/draw) +(define (pretty-print-color-maps (width 400) (height 30)) + (define cm-names + (sort (color-map-names) + (lambda (a b) + (string<=? (symbol->string a) (symbol->string b))))) + (define cm-labels + (for/list ([cm cm-names]) + (text (symbol->string cm) null 16))) + (define cm-picts + (for/list ([cm cm-names]) + (parameterize ([plot-pen-color-map cm]) + (define w (/ width (color-map-size cm))) + (apply + hc-append 0 + (for/list ([c (in-range (color-map-size cm))]) + (match-define (list r g b) (->pen-color c)) + (define color (make-object color% r g b)) + (filled-rectangle w height #:draw-border? #f #:color color)))))) + (define picts + (let loop ([result '()] + [labels cm-labels] + [picts cm-picts]) + (if (null? labels) + (reverse result) + (loop (cons (car picts) (cons (car labels) result)) + (cdr labels) + (cdr picts))))) + (table 2 picts lc-superimpose cc-superimpose 15 3)) diff -Nru racket-7.2+ppa2/share/pkgs/plot-doc/plot/scribblings/params.scrbl racket-7.3+ppa1/share/pkgs/plot-doc/plot/scribblings/params.scrbl --- racket-7.2+ppa2/share/pkgs/plot-doc/plot/scribblings/params.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/plot-doc/plot/scribblings/params.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -161,6 +161,34 @@ When @(racket #f), axes, axis labels, ticks, tick labels, and the title are not drawn. } +@deftogether[((defparam plot-pen-color-map name (or/c symbol? #f) #:value #f) + (defparam plot-brush-color-map name (or/c symbol? #f) #:value #f))]{ + +Specify the color maps to be used by @racket[->pen-color] and +@racket[->brush-color] respectively, for converting integer values into RGB +triplets, or when integer values are used with the @racket[#:color] keyword of +various plot renderers. You can determine the list of available color map +names using @racket[color-map-names]. + +If @racket[name] is not a valid color map name, the internal color map will be +used, this is the same as specifying @racket[#f]. + +When the color map value is set to @racket[#f], internal color maps will be +used, one for pen and one for brush colors. The internal color map used for +pen colors has darker and more saturated colors than the one used for brush +colors. These colors are chosen for good pairwise contrast, especially +between neighbors and they repeat starting with @(racket 128). + +The color maps available by default are shown below and additional ones can be +added using @racket[register-color-map]: + +@centered{@(pretty-print-color-maps)} + +@history[#:added "7.3"] + +} + + @section{Lines} @defparam[line-samples n (and/c exact-integer? (>=/c 2)) #:value 500]{ diff -Nru racket-7.2+ppa2/share/pkgs/plot-doc/plot/scribblings/utils.scrbl racket-7.3+ppa1/share/pkgs/plot-doc/plot/scribblings/utils.scrbl --- racket-7.2+ppa2/share/pkgs/plot-doc/plot/scribblings/utils.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/plot-doc/plot/scribblings/utils.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -190,11 +190,11 @@ } @defproc[(->pen-color [c plot-color/c]) (list/c real? real? real?)]{ -Converts a @italic{line} color to an RGB triplet. This function interprets integer colors as darker and more saturated than @(racket ->brush-color) does. -Non-integer colors are converted using @(racket ->color). -Integer colors are chosen for good pairwise contrast, especially between neighbors. -Integer colors repeat starting with @(racket 128). +Convert a @italic{line} color to an RGB triplet. Integer colors are looked up +in the current @racket[plot-pen-color-map], and non-integer colors are +converted using @(racket ->color). When the integer color is larger than the +number of colors in the color map, it will wrap around. @examples[#:eval plot-eval (equal? (->pen-color 0) (->pen-color 8)) @@ -204,12 +204,15 @@ #:colors (map ->pen-color (build-list 8 values))))] } +The example above is using the internal color map, with +@racket[plot-pen-color-map] set to @racket[#f]. + @defproc[(->brush-color [c plot-color/c]) (list/c real? real? real?)]{ -Converts a @italic{fill} color to an RGB triplet. This function interprets integer colors as lighter and less saturated than @(racket ->pen-color) does. -Non-integer colors are converted using @(racket ->color). -Integer colors are chosen for good pairwise contrast, especially between neighbors. -Integer colors repeat starting with @(racket 128). +Convert a @italic{fill} color to an RGB triplet. Integer colors are looked up +in the current @racket[plot-brush-color-map] and non-integer colors are +converted using @(racket ->color). When the integer color is larger than the +number of colors in the color map, it will wrap around. @examples[#:eval plot-eval (equal? (->brush-color 0) (->brush-color 8)) @@ -218,7 +221,11 @@ #:levels 7 #:contour-styles '(transparent) #:colors (map ->brush-color (build-list 8 values))))] -In the above example, @(racket map)ping @(racket ->brush-color) over the list is actually unnecessary, because @(racket contour-intervals) uses @(racket ->brush-color) internally to convert fill colors. +The example above is using the internal color map, with +@racket[plot-brush-color-map] is set to @racket[#f]. In this example, @(racket +map)ping @(racket ->brush-color) over the list is actually unnecessary, +because @(racket contour-intervals) uses @(racket ->brush-color) internally to +convert fill colors. The @(racket function-interval) function generally plots areas using a fill color and lines using a line color. Both kinds of color have the default value @(racket 3). @@ -251,6 +258,34 @@ (map ->brush-style '(4 5 6))] } +@defproc[(color-map-names) (listof symbol?)]{ + +Return the list of available color map names to be used by +@racket[plot-pen-color-map] and @racket[plot-brush-color-map]. + +@history[#:added "7.3"] + +} + +@defproc[(color-map-size (name symbol?)) integer?]{ + +Return the number of colors in the color map @racket[name]. If @racket[name] +is not a valid color map name, the function will signal an error. + +@history[#:added "7.3"] + +} + +@defproc[(register-color-map (name symbol?) (color-map (vectorof (list byte? byte? byte?)))) void]{ + +Register a new color map @racket[name] with the colors being a vector of RGB +triplets. If a color map by that name already exists, it is replaced. + +@history[#:added "7.3"] + +} + + @;==================================================================================================== @section{Plot-Specific Math} diff -Nru racket-7.2+ppa2/share/pkgs/plot-gui-lib/info.rkt racket-7.3+ppa1/share/pkgs/plot-gui-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/plot-gui-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/plot-gui-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/plot-gui-lib/plot/private/gui/plot2d.rkt racket-7.3+ppa1/share/pkgs/plot-gui-lib/plot/private/gui/plot2d.rkt --- racket-7.2+ppa2/share/pkgs/plot-gui-lib/plot/private/gui/plot2d.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/plot-gui-lib/plot/private/gui/plot2d.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1,6 +1,7 @@ #lang typed/racket/base (require (only-in typed/mred/mred Snip% Frame%) + (only-in racket/gui/base get-display-backing-scale) typed/racket/draw typed/racket/class racket/match plot/utils plot/private/common/parameter-group @@ -61,23 +62,20 @@ (define (make-bm anim? bounds-rect width height) (: area (U #f (Instance 2D-Plot-Area%))) (define area #f) - (define bm - (parameterize/group ([plot-parameters saved-plot-parameters] - [plot-animating? (if anim? #t (plot-animating?))]) - ((if (plot-animating?) draw-bitmap draw-bitmap/supersampling) - (λ (dc) - (define-values (x-ticks x-far-ticks y-ticks y-far-ticks) - (get-ticks renderer-list bounds-rect)) - - (define new-area - (make-object 2d-plot-area% - bounds-rect x-ticks x-far-ticks y-ticks y-far-ticks - dc 0 0 width height)) - - (set! area new-area) - - (plot-area new-area renderer-list)) - width height))) + (define bm (make-bitmap + width height #t + #:backing-scale (or (get-display-backing-scale) 1.0))) + (parameterize/group ([plot-parameters saved-plot-parameters] + [plot-animating? (if anim? #t (plot-animating?))]) + (define dc (make-object bitmap-dc% bm)) + (define-values (x-ticks x-far-ticks y-ticks y-far-ticks) + (get-ticks renderer-list bounds-rect)) + (define new-area + (make-object 2d-plot-area% + bounds-rect x-ticks x-far-ticks y-ticks y-far-ticks + dc 0 0 width height)) + (set! area new-area) + (plot-area new-area renderer-list)) (values bm area)) (define-values (bm area) (make-bm #f bounds-rect width height)) diff -Nru racket-7.2+ppa2/share/pkgs/plot-gui-lib/plot/private/gui/plot3d.rkt racket-7.3+ppa1/share/pkgs/plot-gui-lib/plot/private/gui/plot3d.rkt --- racket-7.2+ppa2/share/pkgs/plot-gui-lib/plot/private/gui/plot3d.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/plot-gui-lib/plot/private/gui/plot3d.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1,6 +1,7 @@ #lang typed/racket/base (require (only-in typed/mred/mred Snip% Frame%) + (only-in racket/gui/base get-display-backing-scale) typed/racket/draw typed/racket/class racket/match racket/list plot/utils plot/private/common/parameter-group @@ -78,36 +79,38 @@ [plot-animating? (if anim? #t (plot-animating?))] [plot3d-angle angle] [plot3d-altitude altitude]) - ((if (plot-animating?) draw-bitmap draw-bitmap/supersampling) - (λ (dc) - (define area (make-object 3d-plot-area% - bounds-rect x-ticks x-far-ticks y-ticks y-far-ticks z-ticks z-far-ticks - dc 0 0 width height)) - (send area start-plot) + (define bm (make-bitmap + width height #t + #:backing-scale (or (get-display-backing-scale) 1.0))) + (define dc (make-object bitmap-dc% bm)) + (define area (make-object 3d-plot-area% + bounds-rect x-ticks x-far-ticks y-ticks y-far-ticks z-ticks z-far-ticks + dc 0 0 width height)) + (send area start-plot) - (cond [(not (hash-ref render-tasks-hash (plot-animating?) #f)) - (hash-set! - legend-entries-hash (plot-animating?) - (flatten-legend-entries - (for/list : (Listof (Treeof legend-entry)) ([rend (in-list renderer-list)]) - (match-define (renderer3d rend-bounds-rect _bf _tf render-proc) rend) - (send area start-renderer (if rend-bounds-rect - (rect-inexact->exact rend-bounds-rect) - (unknown-rect 3))) - (if render-proc (render-proc area) empty)))) - - (hash-set! render-tasks-hash (plot-animating?) (send area get-render-tasks))] - [else - (send area set-render-tasks (hash-ref render-tasks-hash (plot-animating?)))]) + (cond [(not (hash-ref render-tasks-hash (plot-animating?) #f)) + (hash-set! + legend-entries-hash (plot-animating?) + (flatten-legend-entries + (for/list : (Listof (Treeof legend-entry)) ([rend (in-list renderer-list)]) + (match-define (renderer3d rend-bounds-rect _bf _tf render-proc) rend) + (send area start-renderer (if rend-bounds-rect + (rect-inexact->exact rend-bounds-rect) + (unknown-rect 3))) + (if render-proc (render-proc area) empty)))) + + (hash-set! render-tasks-hash (plot-animating?) (send area get-render-tasks))] + [else + (send area set-render-tasks (hash-ref render-tasks-hash (plot-animating?)))]) - (send area end-renderers) - - (define legend-entries (hash-ref legend-entries-hash (plot-animating?) #f)) - (when (and legend-entries (not (empty? legend-entries))) - (send area draw-legend legend-entries)) - - (send area end-plot)) - width height))) + (send area end-renderers) + + (define legend-entries (hash-ref legend-entries-hash (plot-animating?) #f)) + (when (and legend-entries (not (empty? legend-entries))) + (send area draw-legend legend-entries)) + + (send area end-plot) + bm)) (make-3d-plot-snip (make-bm #f angle altitude width height) saved-plot-parameters diff -Nru racket-7.2+ppa2/share/pkgs/plot-gui-lib/plot/private/gui/snip2d.rkt racket-7.3+ppa1/share/pkgs/plot-gui-lib/plot/private/gui/snip2d.rkt --- racket-7.2+ppa2/share/pkgs/plot-gui-lib/plot/private/gui/snip2d.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/plot-gui-lib/plot/private/gui/snip2d.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -8,6 +8,7 @@ plot/private/common/parameter-groups plot/private/common/parameter-group plot/private/common/draw-attribs + plot/private/common/color-map plot/private/plot2d/plot-area plot/private/plot2d/renderer plot/private/no-gui/plot2d-utils @@ -361,8 +362,7 @@ (set! width w) (set! height h) (stop-message) - (when (not (update-thread-running?)) - (start-update-thread #t)) + (start-update-thread #f) (set-update #t)) (super resize w h)) )) diff -Nru racket-7.2+ppa2/share/pkgs/plot-gui-lib/plot/private/gui/snip.rkt racket-7.3+ppa1/share/pkgs/plot-gui-lib/plot/private/gui/snip.rkt --- racket-7.2+ppa2/share/pkgs/plot-gui-lib/plot/private/gui/snip.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/plot-gui-lib/plot/private/gui/snip.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -6,6 +6,7 @@ plot/private/common/parameter-groups plot/private/common/parameter-group plot/private/common/draw-attribs + plot/private/common/color-map "worker-thread.rkt") (provide plot-snip%) diff -Nru racket-7.2+ppa2/share/pkgs/plot-lib/info.rkt racket-7.3+ppa1/share/pkgs/plot-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/plot-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/plot-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/plot-lib/plot/private/common/color-map.rkt racket-7.3+ppa1/share/pkgs/plot-lib/plot/private/common/color-map.rkt --- racket-7.2+ppa2/share/pkgs/plot-lib/plot/private/common/color-map.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/plot-lib/plot/private/common/color-map.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,286 @@ +#lang typed/racket/base +(require racket/match + racket/math + "draw-attribs.rkt" + "type-doc.rkt" + "types.rkt" + "parameters.rkt") + + +;;.................................... declare the predefined color maps .... + +;; These color maps correspond to the Matplotlib 3.0.3 qualitative color maps +;; with the same names. See +;; https://matplotlib.org/examples/color/colormaps_reference.html + +(: color-map-pastel1 Color-Map) +(define color-map-pastel1 + #((251 180 174) + (179 205 227) + (204 235 197) + (222 203 228) + (254 217 166) + (255 255 204) + (229 216 189) + (253 218 236) + (242 242 242))) + +(: color-map-pastel2 Color-Map) +(define color-map-pastel2 + #((179 226 205) + (253 205 172) + (203 213 232) + (244 202 228) + (230 245 201) + (255 242 174) + (241 226 204) + (204 204 204))) + +(: color-map-paired Color-Map) +(define color-map-paired + #((166 206 227) + (31 120 180) + (178 223 138) + (51 160 44) + (251 154 153) + (227 26 28) + (253 191 111) + (255 127 0) + (202 178 214) + (106 61 154) + (255 255 153) + (177 89 40))) + +(: color-map-accent Color-Map) +(define color-map-accent + #((127 201 127) + (190 174 212) + (253 192 134) + (255 255 153) + (56 108 176) + (240 2 127) + (191 91 22) + (102 102 102))) + +(: color-map-dark2 Color-Map) +(define color-map-dark2 + #((27 158 119) + (217 95 2) + (117 112 179) + (231 41 138) + (102 166 30) + (230 171 2) + (166 118 29) + (102 102 102))) + +(: color-map-set1 Color-Map) +(define color-map-set1 + #((228 26 28) + (55 126 184) + (77 175 74) + (152 78 163) + (255 127 0) + (255 255 51) + (166 86 40) + (247 129 191) + (153 153 153))) + +(: color-map-set2 Color-Map) +(define color-map-set2 + #((102 194 165) + (252 141 98) + (141 160 203) + (231 138 195) + (166 216 84) + (255 217 47) + (229 196 148) + (179 179 179))) + +(: color-map-set3 Color-Map) +(define color-map-set3 + #((141 211 199) + (255 255 179) + (190 186 218) + (251 128 114) + (128 177 211) + (253 180 98) + (179 222 105) + (252 205 229) + (217 217 217) + (188 128 189) + (204 235 197) + (255 237 111))) + +(: color-map-tab10 Color-Map) +(define color-map-tab10 + #((31 119 180) + (255 127 14) + (44 160 44) + (214 39 40) + (148 103 189) + (140 86 75) + (227 119 194) + (127 127 127) + (188 189 34) + (23 190 207))) + +(: color-map-tab20 Color-Map) +(define color-map-tab20 + #((31 119 180) + (174 199 232) + (255 127 14) + (255 187 120) + (44 160 44) + (152 223 138) + (214 39 40) + (255 152 150) + (148 103 189) + (197 176 213) + (140 86 75) + (196 156 148) + (227 119 194) + (247 182 210) + (127 127 127) + (199 199 199) + (188 189 34) + (219 219 141) + (23 190 207) + (158 218 229))) + +(: color-map-tab20b Color-Map) +(define color-map-tab20b + #((57 59 121) + (82 84 163) + (107 110 207) + (156 158 222) + (99 121 57) + (140 162 82) + (181 207 107) + (206 219 156) + (140 109 49) + (189 158 57) + (231 186 82) + (231 203 148) + (132 60 57) + (173 73 74) + (214 97 107) + (231 150 156) + (123 65 115) + (165 81 148) + (206 109 189) + (222 158 214))) + +(: color-map-tab20c Color-Map) +(define color-map-tab20c + #((49 130 189) + (107 174 214) + (158 202 225) + (198 219 239) + (230 85 13) + (253 141 60) + (253 174 107) + (253 208 162) + (49 163 84) + (116 196 118) + (161 217 155) + (199 233 192) + (117 107 177) + (158 154 200) + (188 189 220) + (218 218 235) + (99 99 99) + (150 150 150) + (189 189 189) + (217 217 217))) + +;; New Tableau 10 color map from +;; https://www.tableau.com/about/blog/2016/7/colors-upgrade-tableau-10-56782 +(: color-map-tab10n Color-Map) +(define color-map-tab10n + #((78 121 165) + (241 143 59) + (224 88 91) + (119 183 178) + (90 161 85) + (237 201 88) + (175 122 160) + (254 158 168) + (156 117 97) + (186 176 172))) + +(define color-maps + (hash-copy ; hash copy will make our hash table mutable, allowing register-color-map to work + (hash + 'pastel1 color-map-pastel1 + 'pastel2 color-map-pastel2 + 'paired color-map-paired + 'dark2 color-map-dark2 + 'set1 color-map-set1 + 'set2 color-map-set2 + 'set3 color-map-set3 + 'tab10 color-map-tab10 + 'tab10n color-map-tab10n + 'tab20 color-map-tab20 + 'tab20b color-map-tab20b + 'tab20c color-map-tab20c))) + + + +;;.................................................. color map interface .... + +(: color-map-names (-> (Listof Symbol))) +(define (color-map-names) + (hash-keys color-maps)) + +(: color-map-size (-> Symbol Nonnegative-Integer)) +(define (color-map-size name) + (define cm (hash-ref color-maps name + (lambda () (error (format "Unknown color map name: ~a" name))))) + (vector-length cm)) + +(: register-color-map (-> Symbol Color-Map Any)) +(define (register-color-map name cm) + (hash-set! color-maps name cm)) + + +(:: ->color-map-pen-color (-> Integer (List Byte Byte Byte))) +(define (->color-map-pen-color index) + (define cm + (cast + (if (symbol? (plot-pen-color-map)) + (hash-ref color-maps (plot-pen-color-map) + (lambda () default-pen-colors)) + default-pen-colors) + Color-Map)) + (define i (modulo index (vector-length cm))) + (vector-ref cm i)) + +(:: ->color-map-brush-color (-> Integer (List Byte Byte Byte))) +(define (->color-map-brush-color index) + (define cm + (cast + (if (symbol? (plot-brush-color-map)) + (hash-ref color-maps (plot-brush-color-map) + (lambda () default-brush-colors)) + default-brush-colors) + Color-Map)) + (define i (modulo index (vector-length cm))) + (vector-ref cm i)) + +(:: ->pen-color (-> Plot-Color (List Real Real Real))) +(define (->pen-color c) + (cond [(exact-integer? c) (->color-map-pen-color c)] + [else (->color c)])) + +(:: ->brush-color (-> Plot-Color (List Real Real Real))) +(define (->brush-color c) + (cond [(exact-integer? c) (->color-map-brush-color c)] + [else (->color c)])) + +(provide + color-map-names + color-map-size + register-color-map + ->pen-color + ->brush-color) + diff -Nru racket-7.2+ppa2/share/pkgs/plot-lib/plot/private/common/draw-attribs.rkt racket-7.3+ppa1/share/pkgs/plot-lib/plot/private/common/draw-attribs.rkt --- racket-7.2+ppa2/share/pkgs/plot-lib/plot/private/common/draw-attribs.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/plot-lib/plot/private/common/draw-attribs.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -154,8 +154,8 @@ (define r (assert (+ 127 (* 128 (expt (max 0 (- 1 (integer->gray-value i))) 3/4))) real?)) (list r r r)) -(: pen-colors (Vectorof (List Byte Byte Byte))) -(define pen-colors +(: default-pen-colors (Vectorof (List Byte Byte Byte))) +(define default-pen-colors (for/vector ([color (in-list (append (list (integer->gray-pen-color 0)) (build-list 120 integer->pen-color) (build-list 7 (λ ([n : Index]) @@ -166,8 +166,8 @@ (real->color-byte g) (real->color-byte b)))) -(: brush-colors (Vectorof (List Byte Byte Byte))) -(define brush-colors +(: default-brush-colors (Vectorof (List Byte Byte Byte))) +(define default-brush-colors (for/vector ([color (in-list (append (list (integer->gray-brush-color 0)) (build-list 120 integer->brush-color) (build-list 7 (λ ([n : Index]) @@ -178,16 +178,6 @@ (real->color-byte g) (real->color-byte b)))) -(:: ->pen-color (-> Plot-Color (List Real Real Real))) -(define (->pen-color c) - (cond [(exact-integer? c) (vector-ref pen-colors (modulo c 128))] - [else (->color c)])) - -(:: ->brush-color (-> Plot-Color (List Real Real Real))) -(define (->brush-color c) - (cond [(exact-integer? c) (vector-ref brush-colors (modulo c 128))] - [else (->color c)])) - (:: ->pen-style (-> Plot-Pen-Style Plot-Pen-Style-Sym)) (define (->pen-style s) (cond [(exact-integer? s) (case (remainder (abs s) 5) @@ -235,3 +225,31 @@ [gs (linear-seq* gs num #:start? start? #:end? end?)] [bs (linear-seq* bs num #:start? start? #:end? end?)]) (map (λ ([r : Real] [g : Real] [b : Real]) (list r g b)) rs gs bs))) + +(:: default-contour-colors (-> (Listof Real) (Listof Plot-Color))) +(define (default-contour-colors zs) + (color-seq* (list (vector-ref default-pen-colors 5) + (vector-ref default-pen-colors 0) + (vector-ref default-pen-colors 1)) + (length zs))) + +(:: default-contour-fill-colors (-> (Listof ivl) (Listof Plot-Color))) +(define (default-contour-fill-colors z-ivls) + (color-seq* (list (vector-ref default-brush-colors 5) + (vector-ref default-brush-colors 0) + (vector-ref default-brush-colors 1)) + (length z-ivls))) + +(:: default-isosurface-colors (-> (Listof Real) (Listof Plot-Color))) +(define (default-isosurface-colors zs) + (color-seq* (list (vector-ref default-brush-colors 5) + (vector-ref default-brush-colors 0) + (vector-ref default-brush-colors 1)) + (length zs))) + +(:: default-isosurface-line-colors (-> (Listof Real) (Listof Plot-Color))) +(define (default-isosurface-line-colors zs) + (color-seq* (list (vector-ref default-pen-colors 5) + (vector-ref default-pen-colors 0) + (vector-ref default-pen-colors 1)) + (length zs))) diff -Nru racket-7.2+ppa2/share/pkgs/plot-lib/plot/private/common/draw.rkt racket-7.3+ppa1/share/pkgs/plot-lib/plot/private/common/draw.rkt --- racket-7.2+ppa2/share/pkgs/plot-lib/plot/private/common/draw.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/plot-lib/plot/private/common/draw.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -429,23 +429,3 @@ (define scale (max 1.0 (fl (send pen get-width)))) (define sty (scale-pen-style (symbol->style style-sym) scale)) (draw-lines* dc vs sty)]))])) - -;; =================================================================================================== -;; Drawing a bitmap using 2x supersampling - -(: draw-bitmap/supersampling (-> (-> (Instance DC<%>) Any) Positive-Integer Positive-Integer - (Instance Bitmap%))) -(define (draw-bitmap/supersampling draw width height) - (define bm (make-bitmap width height #:backing-scale 2)) - (define dc (make-object bitmap-dc% bm)) - (send dc set-alignment-scale 2) - (draw dc) - bm) - -(: draw-bitmap (-> (-> (Instance DC<%>) Any) Positive-Integer Positive-Integer - (Instance Bitmap%))) -(define (draw-bitmap draw width height) - (define bm (make-bitmap width height)) - (define dc (make-object bitmap-dc% bm)) - (draw dc) - bm) diff -Nru racket-7.2+ppa2/share/pkgs/plot-lib/plot/private/common/parameter-groups.rkt racket-7.3+ppa1/share/pkgs/plot-lib/plot/private/common/parameter-groups.rkt --- racket-7.2+ppa2/share/pkgs/plot-lib/plot/private/common/parameter-groups.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/plot-lib/plot/private/common/parameter-groups.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -35,7 +35,9 @@ plot-legend-anchor plot-legend-box-alpha plot-axes? plot-tick-labels plot-decorations? - plot-animating?)) + plot-animating? + plot-pen-color-map + plot-brush-color-map)) (define-parameter-group plot3d-appearance (plot3d-samples @@ -95,7 +97,9 @@ (List Boolean Boolean Boolean Boolean Boolean Boolean) (List Boolean Anchor Real (U Boolean 'auto) Anchor Real Boolean Anchor Real (U Boolean 'auto) Anchor Real) Boolean - Boolean) + Boolean + (U Symbol #f) + (U Symbol #f)) (List Positive-Integer Real Real Nonnegative-Real Boolean Boolean) (List (U False String) diff -Nru racket-7.2+ppa2/share/pkgs/plot-lib/plot/private/common/parameters.rkt racket-7.3+ppa1/share/pkgs/plot-lib/plot/private/common/parameters.rkt --- racket-7.2+ppa2/share/pkgs/plot-lib/plot/private/common/parameters.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/plot-lib/plot/private/common/parameters.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -62,8 +62,8 @@ (defparam2 plot-width Integer Positive-Integer 400 (integer>=1 'plot-width)) (defparam2 plot-height Integer Positive-Integer 400 (integer>=1 'plot-height)) -(defparam plot-foreground color Plot-Color 0) -(defparam plot-background color Plot-Color 0) +(defparam plot-foreground color Plot-Color "black") +(defparam plot-background color Plot-Color "white") (defparam2 plot-foreground-alpha alpha Real Nonnegative-Real 1 (unit-ivl 'plot-foreground-alpha)) (defparam2 plot-background-alpha alpha Real Nonnegative-Real 1 (unit-ivl 'plot-background-alpha)) (defparam2 plot-line-width width Real Nonnegative-Real 1 (nonnegative-rational 'plot-line-width)) @@ -103,6 +103,9 @@ (defparam plot-decorations? Boolean #t) +(defparam plot-pen-color-map (U Symbol #f) #f) +(defparam plot-brush-color-map (U Symbol #f) #f) + (:: pen-gap (-> Real)) (define (pen-gap) (max 1 (* 2 (plot-line-width)))) @@ -224,16 +227,6 @@ ;; Contours -(:: default-contour-colors (-> (Listof Real) (Listof Plot-Color))) -(define (default-contour-colors zs) - (color-seq* (list (->pen-color 5) (->pen-color 0) (->pen-color 1)) - (length zs))) - -(:: default-contour-fill-colors (-> (Listof ivl) (Listof Plot-Color))) -(define (default-contour-fill-colors z-ivls) - (color-seq* (list (->brush-color 5) (->brush-color 0) (->brush-color 1)) - (length z-ivls))) - (defparam2 contour-samples Integer Positive-Integer 51 (integer>=2 'contour-samples)) (defparam contour-levels Contour-Levels 'auto) (defparam contour-colors (Plot-Colors (Listof Real)) default-contour-colors) @@ -313,16 +306,6 @@ ;; Isosurfaces -(:: default-isosurface-colors (-> (Listof Real) (Listof Plot-Color))) -(define (default-isosurface-colors zs) - (color-seq* (list (->brush-color 5) (->brush-color 0) (->brush-color 1)) - (length zs))) - -(:: default-isosurface-line-colors (-> (Listof Real) (Listof Plot-Color))) -(define (default-isosurface-line-colors zs) - (color-seq* (list (->pen-color 5) (->pen-color 0) (->pen-color 1)) - (length zs))) - (defparam isosurface-levels Contour-Levels 'auto) (defparam isosurface-colors (Plot-Colors (Listof Real)) default-isosurface-colors) (defparam isosurface-styles (Plot-Brush-Styles (Listof Real)) '(solid)) diff -Nru racket-7.2+ppa2/share/pkgs/plot-lib/plot/private/common/plot-device.rkt racket-7.3+ppa1/share/pkgs/plot-lib/plot/private/common/plot-device.rkt --- racket-7.2+ppa2/share/pkgs/plot-lib/plot/private/common/plot-device.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/plot-lib/plot/private/common/plot-device.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -10,6 +10,7 @@ typed/racket/class racket/match racket/math racket/bool racket/list racket/vector "draw-attribs.rkt" + "color-map.rkt" "draw.rkt" "math.rkt" "sample.rkt" diff -Nru racket-7.2+ppa2/share/pkgs/plot-lib/plot/private/common/types.rkt racket-7.3+ppa1/share/pkgs/plot-lib/plot/private/common/types.rkt --- racket-7.2+ppa2/share/pkgs/plot-lib/plot/private/common/types.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/plot-lib/plot/private/common/types.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -27,6 +27,8 @@ (deftype Plot-Color (U Integer Color)) +(deftype Color-Map (Vectorof (List Byte Byte Byte))) + (deftype Plot-Pen-Style-Sym (U 'transparent 'solid 'dot 'long-dash 'short-dash 'dot-dash)) diff -Nru racket-7.2+ppa2/share/pkgs/plot-lib/plot/private/no-gui/plot2d.rkt racket-7.3+ppa1/share/pkgs/plot-lib/plot/private/no-gui/plot2d.rkt --- racket-7.2+ppa2/share/pkgs/plot-lib/plot/private/no-gui/plot2d.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/plot-lib/plot/private/no-gui/plot2d.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -91,12 +91,12 @@ #:x-label [x-label (plot-x-label)] #:y-label [y-label (plot-y-label)] #:legend-anchor [legend-anchor (plot-legend-anchor)]) - ((if (plot-animating?) draw-bitmap draw-bitmap/supersampling) - (λ (dc) - (plot/dc renderer-tree dc 0 0 width height - #:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max - #:title title #:x-label x-label #:y-label y-label #:legend-anchor legend-anchor)) - width height)) + (define bm (make-bitmap width height)) + (define dc (make-object bitmap-dc% bm)) + (plot/dc renderer-tree dc 0 0 width height + #:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max + #:title title #:x-label x-label #:y-label y-label #:legend-anchor legend-anchor) + bm) ;; =================================================================================================== ;; Plot to a pict diff -Nru racket-7.2+ppa2/share/pkgs/plot-lib/plot/private/no-gui/plot3d.rkt racket-7.3+ppa1/share/pkgs/plot-lib/plot/private/no-gui/plot3d.rkt --- racket-7.2+ppa2/share/pkgs/plot-lib/plot/private/no-gui/plot3d.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/plot-lib/plot/private/no-gui/plot3d.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -121,13 +121,13 @@ #:y-label [y-label (plot-y-label)] #:z-label [z-label (plot-z-label)] #:legend-anchor [legend-anchor (plot-legend-anchor)]) - ((if (plot-animating?) draw-bitmap draw-bitmap/supersampling) - (λ (dc) - (plot3d/dc renderer-tree dc 0 0 width height - #:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max #:z-min z-min #:z-max z-max - #:angle angle #:altitude altitude #:title title #:x-label x-label #:y-label y-label - #:z-label z-label #:legend-anchor legend-anchor)) - width height)) + (define bm (make-bitmap width height)) + (define dc (make-object bitmap-dc% bm)) + (plot3d/dc renderer-tree dc 0 0 width height + #:x-min x-min #:x-max x-max #:y-min y-min #:y-max y-max #:z-min z-min #:z-max z-max + #:angle angle #:altitude altitude #:title title #:x-label x-label #:y-label y-label + #:z-label z-label #:legend-anchor legend-anchor) + bm) ;; =================================================================================================== ;; Plot to a pict diff -Nru racket-7.2+ppa2/share/pkgs/plot-lib/plot/private/plot3d/plot-area.rkt racket-7.3+ppa1/share/pkgs/plot-lib/plot/private/plot3d/plot-area.rkt --- racket-7.2+ppa2/share/pkgs/plot-lib/plot/private/plot3d/plot-area.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/plot-lib/plot/private/plot3d/plot-area.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -8,6 +8,7 @@ "../common/plot-device.rkt" "../common/ticks.rkt" "../common/draw-attribs.rkt" + "../common/color-map.rkt" "../common/draw.rkt" "../common/axis-transform.rkt" "../common/parameters.rkt" diff -Nru racket-7.2+ppa2/share/pkgs/plot-lib/plot/private/utils-and-no-gui.rkt racket-7.3+ppa1/share/pkgs/plot-lib/plot/private/utils-and-no-gui.rkt --- racket-7.2+ppa2/share/pkgs/plot-lib/plot/private/utils-and-no-gui.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/plot-lib/plot/private/utils-and-no-gui.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -47,7 +47,8 @@ stretch-transform collapse-transform) -(require "common/parameters.rkt") +(require "common/parameters.rkt" + "common/draw-attribs.rkt") (provide plot-deprecation-warnings? @@ -86,6 +87,8 @@ plot-legend-box-alpha plot-decorations? plot-animating? + plot-pen-color-map + plot-brush-color-map plot3d-samples plot3d-angle plot3d-altitude diff -Nru racket-7.2+ppa2/share/pkgs/plot-lib/plot/utils.rkt racket-7.3+ppa1/share/pkgs/plot-lib/plot/utils.rkt --- racket-7.2+ppa2/share/pkgs/plot-lib/plot/utils.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/plot-lib/plot/utils.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -142,16 +142,25 @@ parse-format-string apply-formatter) -(require "private/common/draw-attribs.rkt") +(require (only-in "private/common/draw-attribs.rkt" + ->color + ->pen-style + ->brush-style + color-seq + color-seq*) + "private/common/color-map.rkt") (provide ->color - ->pen-color - ->brush-color ->pen-style ->brush-style color-seq - color-seq*) + color-seq* + ->pen-color + ->brush-color + color-map-names + color-map-size + register-color-map) (require "private/common/sample.rkt") diff -Nru racket-7.2+ppa2/share/pkgs/preprocessor/info.rkt racket-7.3+ppa1/share/pkgs/preprocessor/info.rkt --- racket-7.2+ppa2/share/pkgs/preprocessor/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/preprocessor/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/profile/info.rkt racket-7.3+ppa1/share/pkgs/profile/info.rkt --- racket-7.2+ppa2/share/pkgs/profile/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/profile/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/profile-doc/info.rkt racket-7.3+ppa1/share/pkgs/profile-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/profile-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/profile-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/profile-lib/info.rkt racket-7.3+ppa1/share/pkgs/profile-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/profile-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/profile-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/profile-lib/raco.rkt racket-7.3+ppa1/share/pkgs/profile-lib/raco.rkt --- racket-7.2+ppa2/share/pkgs/profile-lib/raco.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/profile-lib/raco.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -45,8 +45,10 @@ [("--total") "Order functions by total time" (set! order 'total)] - #:args (filename) - filename)) + #:args (file.rkt . arg-for-file.rkt) + (current-command-line-arguments + (list->vector arg-for-file.rkt)) + file.rkt)) (define (t) ;; use a fresh namespace every time, to play nice with --repeat diff -Nru racket-7.2+ppa2/share/pkgs/quickscript/base.rkt racket-7.3+ppa1/share/pkgs/quickscript/base.rkt --- racket-7.2+ppa2/share/pkgs/quickscript/base.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/quickscript/base.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1,7 +1,9 @@ #lang at-exp racket/base (require racket/dict - racket/path racket/format + racket/path + compiler/compilation-path + compiler/compiler ) (provide (all-defined-out)) @@ -9,6 +11,8 @@ (module+ test (require rackunit)) +(define version-bytes (string->bytes/utf-8 (version))) + (define-logger quickscript) (define quickscript-dir @@ -152,3 +156,38 @@ help-str help-str2) ) + +;===================; +;=== Compilation ===; +;===================; + +(define (compile-user-scripts files) + ; Docs say generates a compiled file in the "compiled" directory + ; (thus not in the "compile d/errortrace" directory). + (define my-compiler (compile-zos #f #:module? #t)) + (time-info + "Compiling user scripts" + (my-compiler files 'auto))) + +; Based on 'read-linklet-bundle-or-directory': +; https://github.com/racket/racket/blob/master/racket/src/expander/compile/read-linklet.rkt#L9 +; and 'get-cached-compiled': +; https://github.com/racket/racket/blob/master/racket/src/expander/run/cache.rkt#L76 +(define (zo-version source-file) + ; We (only) use "compiled" as modes, because by default DrRacket would place zos in + ; compiled/errortrace, but the compile-zos used in compile-user-scripts places them in + ; "compiled". + (define zo-file (get-compilation-bytecode-file source-file #:modes '("compiled"))) + (and (file-exists? zo-file) + (parameterize ([read-accept-compiled #t]) + (call-with-input-file* + zo-file + (lambda (in) + (read-bytes 2 in) ; consume "#~" + (define vers-len (min 63 (read-byte in))) + (read-bytes vers-len in)))))) + +;; Is the zo file for the given source file having the same version as +;; the current (dr)racket one? +(define (compiled-for-current-version? source-file) + (equal? version-bytes (zo-version source-file))) diff -Nru racket-7.2+ppa2/share/pkgs/quickscript/info.rkt racket-7.3+ppa1/share/pkgs/quickscript/info.rkt --- racket-7.2+ppa2/share/pkgs/quickscript/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/quickscript/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (define deps (quote ("base" "drracket-plugin-lib" "gui-lib" "net-lib" "scribble-lib"))) (define build-deps (quote ("at-exp-lib" "drracket" "gui-doc" "racket-doc" "draw-doc" "rackunit-lib"))) (define name "Quickscript") (define drracket-tools (quote (("tool.rkt")))) (define drracket-tool-names (quote ("Quickscript"))) (define drracket-tool-icons (quote (#f))) (define scribblings (quote (("scribblings/quickscript.scrbl" () (tool) "quickscript")))) (define compile-omit-paths (quote ())))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.3"))) (define deps (quote ("base" "drracket-plugin-lib" "gui-lib" "net-lib" "scribble-lib"))) (define build-deps (quote ("at-exp-lib" "drracket" "gui-doc" "racket-doc" "draw-doc" "rackunit-lib"))) (define name "Quickscript") (define drracket-tools (quote (("tool.rkt")))) (define drracket-tool-names (quote ("Quickscript"))) (define drracket-tool-icons (quote (#f))) (define scribblings (quote (("scribblings/quickscript.scrbl" () (tool) "quickscript")))) (define compile-omit-paths (quote ())))) diff -Nru racket-7.2+ppa2/share/pkgs/quickscript/library.rkt racket-7.3+ppa1/share/pkgs/quickscript/library.rkt --- racket-7.2+ppa2/share/pkgs/quickscript/library.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/quickscript/library.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -32,21 +32,26 @@ (define (exclusions lib dir) (dict-ref lib (path-string->string dir) '())) -;; Returns the list of script files in the given directory that are not listed as exclusions -;; in the library. -(define (files lib [dir user-script-dir]) +;; Returns the list of script files in the given directory. +;; If exclude is not #f, then only such files that are not listed as exclusions +;; in the library are returned. +(define (files lib [dir user-script-dir] #:exclude? [exclude? #t]) (define script-files (map path->string (filter (λ (f) (script-file? (build-path dir f))) (if (directory-exists? dir) (directory-list dir #:build? #f) '())))) - (define except-list (exclusions lib dir)) - (set-subtract script-files except-list)) - -(define (all-files lib) + (cond [exclude? + (define except-list (exclusions lib dir)) + (set-subtract script-files except-list)] + [else script-files])) + +;; Returns the list full paths of script files --in all listed directories of the library. +;; The keyword argument `exclude?' is as in `files'. +(define (all-files lib #:exclude? [exclude? #t]) (for*/list ([dir (in-dict-keys lib)] - [f (in-list (files lib dir))]) + [f (in-list (files lib dir #:exclude? exclude?))]) (build-path dir f))) @@ -92,10 +97,11 @@ path-string? . -> . (listof string?))] [files ([library?] - [path-string?] + [path-string? #:exclude? boolean?] . ->* . (listof string?))] - [all-files (library? - . -> . (listof path-string?))] + [all-files ([library?] + [#:exclude? boolean?] + . ->* . (listof path-string?))] [add-directory! ([library? (and/c path-string? absolute-path? directory-exists?)] [list?] diff -Nru racket-7.2+ppa2/share/pkgs/quickscript/tool.rkt racket-7.3+ppa1/share/pkgs/quickscript/tool.rkt --- racket-7.2+ppa2/share/pkgs/quickscript/tool.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/quickscript/tool.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1,7 +1,6 @@ #lang at-exp racket/base (require (for-syntax racket/base) ; for help menu - compiler/compiler drracket/tool ; necessary to build a drracket plugin #;framework ; for preferences (too heavy a package?) help/search @@ -31,19 +30,40 @@ |# -(define (user-script-files) - (lib:all-files (lib:load library-file))) +(define (user-script-files #:exclude? [exclude? #t]) + (lib:all-files (lib:load library-file) #:exclude? exclude?)) (define (error-message-box filename e) - (message-box filename + (message-box "Quickscript caught an exception" #;filename (format "Error in script file ~s: ~a" filename (exn-message e)) #f '(stop ok))) -(define (compile-user-scripts) - (define my-compiler (compile-zos #f #:module? #t)) - (time-info - "Compiling user scripts" - (my-compiler (user-script-files) 'auto))) +;; Recompiles all (enabled or disabled, user and third-party) scripts that are not yet compiled +;; for the current version. +;; This is to prevent Quickscript trying to load from compiled after an upgrade of +;; the Racket system, and displaying one error message for each script. +;; It is important to recompile disabled scripts too, because these may still be +;; dependencies of shadowing scripts. +;; Caveat: Dependencies are not compiled automatically. Hence if a script depends on a collection +;; (package) then the collection needs to be compiled with the correct version, otherwise +;; an error will be raised on DrRacket startup. +;; How to test this works: +;; - Create a new script or use an old one that is *not* deactivated in the library +;; - Compile it with another version of racket (install locally, not unix style, +;; then use its old raco to setup quickscript and make the script) +;; - In DrRacket, use the quickscript "Compiled version" to make sure it has the old version. +;; - Exit DrRacket. +;; - Use the new version of raco to setup (again) quickscript +;; If installing a new version of racket, it may be necessary to run: +;; $ raco pkg update --link +;; - Restart DrRacket, the script should be compiled silently with the correct version, +;; and no error message should be displayed. +;; - In the library, check that a quickscript-extra shadowed script does not raise an error +;; when clicking on it. +(define (recompile-all-of-previous-version) + (compile-user-scripts + (filter (λ (f) (not (compiled-for-current-version? f))) + (user-script-files #:exclude? #f)))) (define-namespace-anchor a) @@ -141,8 +161,8 @@ (define ed-file (send (get-definitions-text) get-filename)) (define str-out (with-handlers ([exn:fail? (λ (e) (error-message-box - (path->string (file-name-from-path file)) - e) + (path->string (file-name-from-path file)) + e) #f)]) ; See HelpDesk for "Manipulating namespaces" (parameterize ([current-namespace ns]) @@ -205,6 +225,7 @@ (for ([item (list-tail (send scripts-menu get-items) 2)]) (log-quickscript-info "Deleting menu item ~a... " (send item get-label)) (send item delete))) + ;; Add script items. ;; Create an empty namespace to load all the scripts (in the same namespace) (parameterize ([current-namespace (make-base-empty-namespace)]) @@ -214,8 +235,8 @@ (string-append "Loading file " (path->string f)) ; catch problems and display them in a message-box (with-handlers ([exn:fail? (λ (e) (error-message-box - (path->string (file-name-from-path f)) - e))]) + (path->string (file-name-from-path f)) + e))]) (define property-dicts (get-property-dicts f)) (for ([(fun props) (in-dict property-dicts)]) (let*([label (prop-dict-ref props 'label)] @@ -237,7 +258,7 @@ (let ([menu (first menu-path)]) (loop (rest menu-path) (or (findf (λ (m) (and (is-a? m labelled-menu-item<%>) - (string=? (send m get-label) menu))) + (string=? (send m get-label) menu))) (send parent get-items)) (new menu% [parent parent] [label menu]))))))) (new menu-item% [parent parent-menu] @@ -261,7 +282,7 @@ #:drracket-parent? #t))) ("&Reload menu" . ,(λ () (reload-scripts-menu))) ("&Compile scripts and reload" . ,(λ () - (compile-user-scripts) + (compile-user-scripts (user-script-files)) (reload-scripts-menu))) ("&Unload persistent scripts" . ,(λ () (unload-persistent-scripts))) (separator . #f) @@ -274,6 +295,8 @@ [callback (λ _ (cbk))]))) (new separator-menu-item% [parent scripts-menu]) + ; Silently recompile for the new version if necessary, at the start up of DrRacket. + (recompile-all-of-previous-version) (reload-scripts-menu) )) diff -Nru racket-7.2+ppa2/share/pkgs/r5rs/info.rkt racket-7.3+ppa1/share/pkgs/r5rs/info.rkt --- racket-7.2+ppa2/share/pkgs/r5rs/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/r5rs/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/r5rs-doc/info.rkt racket-7.3+ppa1/share/pkgs/r5rs-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/r5rs-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/r5rs-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/r5rs-lib/info.rkt racket-7.3+ppa1/share/pkgs/r5rs-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/r5rs-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/r5rs-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/r6rs/info.rkt racket-7.3+ppa1/share/pkgs/r6rs/info.rkt --- racket-7.2+ppa2/share/pkgs/r6rs/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/r6rs/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/r6rs-doc/info.rkt racket-7.3+ppa1/share/pkgs/r6rs-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/r6rs-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/r6rs-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/r6rs-lib/info.rkt racket-7.3+ppa1/share/pkgs/r6rs-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/r6rs-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/r6rs-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/r6rs-lib/rnrs/arithmetic/fixnums-6.rkt racket-7.3+ppa1/share/pkgs/r6rs-lib/rnrs/arithmetic/fixnums-6.rkt --- racket-7.2+ppa2/share/pkgs/r6rs-lib/rnrs/arithmetic/fixnums-6.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/r6rs-lib/rnrs/arithmetic/fixnums-6.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -22,11 +22,20 @@ fxreverse-bit-field) ;; Many other provides from macros below +(define CS? (eq? 'chez-scheme (system-type 'vm))) (define 64-bit? (fixnum? (expt 2 33))) -(define (fixnum-width) (if 64-bit? 63 31)) -(define (least-fixnum) (if 64-bit? (- (expt 2 62)) -1073741824)) -(define (greatest-fixnum) (if 64-bit? (- (expt 2 62) 1) +1073741823)) +;; These would be better provided by Racket, instead of hardwiring +;; numbers based on `system-type` results... +(define (fixnum-width) (if CS? + (if 64-bit? 61 30) + (if 64-bit? 63 31))) +(define (least-fixnum) (if CS? + (if 64-bit? (- (expt 2 60)) -536870912) + (if 64-bit? (- (expt 2 62)) -1073741824))) +(define (greatest-fixnum) (if CS? + (if 64-bit? (- (expt 2 60) 1) +536870911) + (if 64-bit? (- (expt 2 62) 1) +1073741823))) (define-syntax-rule (check v alt) (if (fixnum? v) diff -Nru racket-7.2+ppa2/share/pkgs/racket-cheat/info.rkt racket-7.3+ppa1/share/pkgs/racket-cheat/info.rkt --- racket-7.2+ppa2/share/pkgs/racket-cheat/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-cheat/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/racket-doc/info.rkt racket-7.3+ppa1/share/pkgs/racket-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/racket-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/racket-doc/pkg/scribblings/pkg.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/pkg/scribblings/pkg.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/pkg/scribblings/pkg.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/pkg/scribblings/pkg.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -616,6 +616,12 @@ @item{@DFlag{no-setup} --- Does not run @exec{raco setup} after installation. This behavior is also the case if the environment variable @envvar{PLT_PKG_NOSETUP} is set to any non-empty value.} + @item{@DFlag{recompile-only} ---Constrains @exec{raco setup} to at most recompile a module from + machine-independent form, reporting an error if compilation from source is needed. This + behavior is useful as a sanity check when installing built packages (to ensure that they + are properly built), but if a compilation error is reported, it will be after the package + is installed.} + @item{@DFlag{jobs} @nonterm{n} or @Flag{j} @nonterm{n} --- Installs and runs @exec{raco setup} with @nonterm{n} parallel jobs.} @item{@DFlag{batch} --- Disables @deftech{interactive mode}, suppressing potential prompts for a user @@ -631,7 +637,8 @@ #: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{pull} flag.} - #:changed "6.4.0.14" @elem{Added the @DFlag{dry-run} flag.}]} + #:changed "6.4.0.14" @elem{Added the @DFlag{dry-run} flag.} + #:changed "7.2.0.8" @elem{Added the @DFlag{recompile-only} flag.}]} @subcommand{@command/toc{update} @nonterm{option} ... @nonterm{pkg-source} ... @@ -746,6 +753,7 @@ @item{@DFlag{dry-run} --- Same as for @command-ref{install}.} @item{@DFlag{no-setup} --- Same as for @command-ref{install}.} + @item{@DFlag{recompile-only} --- Same as for @command-ref{install}.} @item{@DFlag{jobs} @nonterm{n} or @Flag{j} @nonterm{n} --- Same as for @command-ref{install}.} @item{@DFlag{batch} --- Same as for @command-ref{install}.} @item{@DFlag{no-trash} --- Same as for @command-ref{install}.} @@ -759,7 +767,8 @@ 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.90.0.27" @elem{Added the @DFlag{unclone} flag.}]} + #:changed "6.90.0.27" @elem{Added the @DFlag{unclone} flag.} + #:changed "7.2.0.8" @elem{Added the @DFlag{recompile-only} flag.}]} @subcommand{@command/toc{remove} @nonterm{option} ... @nonterm{pkg} ... --- Attempts to remove the given packages. By default, if a package is the dependency @@ -787,6 +796,7 @@ @item{@DFlag{scope-dir} @nonterm{dir} --- Selects @nonterm{dir} as the @tech{package scope}, the same as for @command-ref{install}.} @item{@DFlag{dry-run} --- Same as for @command-ref{install}.} @item{@DFlag{no-setup} --- Same as for @command-ref{install}.} + @item{@DFlag{recompile-only} --- Same as for @command-ref{install}.} @item{@DFlag{jobs} @nonterm{n} or @Flag{j} @nonterm{n} --- Same as for @command-ref{install}.} @item{@DFlag{batch} --- Same as for @command-ref{install}.} @item{@DFlag{no-trash} --- Same as for @command-ref{install}.} @@ -794,7 +804,8 @@ @history[#:changed "6.1.1.5" @elem{Added the @DFlag{batch} flag.} #:changed "6.1.1.6" @elem{Added the @DFlag{no-trash} flag.} - #:changed "6.4.0.14" @elem{Added the @DFlag{dry-run} flag.}]} + #:changed "6.4.0.14" @elem{Added the @DFlag{dry-run} flag.} + #:changed "7.2.0.8" @elem{Added the @DFlag{recompile-only} flag.}]} @subcommand{@command/toc{new} @nonterm{pkg} --- @@ -878,10 +889,12 @@ @item{@DFlag{no-cache} --- Same as for @command-ref{install}.} @item{@DFlag{dry-run} --- Same as for @command-ref{install}.} @item{@DFlag{no-setup} --- Same as for @command-ref{install}.} + @item{@DFlag{recompile-only} --- Same as for @command-ref{install}.} @item{@DFlag{jobs} @nonterm{n} or @Flag{j} @nonterm{n} --- Same as for @command-ref{install}.} ] -@history[#:changed "6.4.0.14" @elem{Added the @DFlag{dry-run} flag.}]} +@history[#:changed "6.4.0.14" @elem{Added the @DFlag{dry-run} flag.} + #:changed "7.2.0.8" @elem{Added the @DFlag{recompile-only} flag.}]} @subcommand{@command/toc{create} @nonterm{option} ... @nonterm{directory-or-package} --- Bundles a package into an archive. Bundling diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/pkg/scribblings/strip.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/pkg/scribblings/strip.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/pkg/scribblings/strip.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/pkg/scribblings/strip.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -223,10 +223,15 @@ omissions and updates corresponding to the creation of a @tech{source package}, @tech{binary package}, @tech{binary library package}, or @tech{built package} as indicated by @racket[mode]. The given @racket[src-dir] and @racket[dest-dir] must both exist already. +If @racket[src-dir] and @racket[dest-dir] are the same, then @racket[src-dir] is +modified directly, which may involve deleting files. Note that @racket[generate-stripped-directory] does not compile or render source files found in the @racket[src-dir]. To perform precompilation or rendering before stripping the source directory, -use @exec{raco setup} or @exec{raco make}.} +use @exec{raco setup} or @exec{raco make}. + +@history[#:changed "7.2.0.10" @elem{Added support for @racket[src-dir] and @racket[dest-dir] + as the same path.}]} @defproc[(check-strip-compatible [mode (or/c 'source 'binary 'binary-lib 'built)] diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/foreign/alloc.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/foreign/alloc.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/foreign/alloc.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/foreign/alloc.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -63,6 +63,9 @@ @racket[dealloc]'s arguments correspond to the released object; @racket[get-arg] receives a list of arguments passed to @racket[dealloc], so the default @racket[car] selects the first one. +Note that @racket[get-arg] can only choose one of the by-position +arguments to @racket[dealloc], though the @tech{deallocator} will +require and accept the same keyword arguments as @racket[dealloc], if any. The @racket[releaser] procedure is a synonym for @racket[deallocator].} @@ -94,6 +97,9 @@ arguments) correspond to the retained object @racket[_v]; @racket[get-arg] receives a list of arguments passed to @racket[retain], so the default @racket[car] selects the first one. +Note that @racket[get-arg] can only choose one of the by-position +arguments to @racket[retain], though the @tech{retainer} will +require and accept the same keyword arguments as @racket[retain], if any. @history[#:changed "7.0.0.4" @elem{Added atomic mode for @racket[release] and changed non-main place exits to call diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/foreign/intro.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/foreign/intro.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/foreign/intro.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/foreign/intro.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -375,7 +375,7 @@ functions, meanwhile, expect to receive pointers to objects that will stay put. -Fortunately, unless a C function calls back into the Racket run-time +Fortunately, unless a C function calls back into the Racket runtime system (perhaps through a function that is provided as an argument), no garbage collection will happen between the time that a C function is called and the time that the function returns. diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/foreign/pointers.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/foreign/pointers.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/foreign/pointers.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/foreign/pointers.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -214,7 +214,7 @@ cpointer?]{ Allocates a memory block of a specified size using a specified -allocation. The result is a @racket[cpointer] to the allocated +allocation. The result is a C pointer to the allocated memory, or @racket[#f] if the requested size is zero. Although not reflected above, the four arguments can appear in any order, since they are all different types of Racket objects; a size @@ -223,7 +223,7 @@ @itemize[ @item{If a C type @racket[bytes-or-type] is given, its size is used - to the block allocation size.} + to determine the block allocation size.} @item{If an integer @racket[bytes-or-type] is given, it specifies the required size in bytes.} @@ -236,21 +236,99 @@ the new block.} @item{A symbol @racket[mode] argument can be given, which specifies - what allocation function to use. It should be one of - @indexed-racket['nonatomic] (uses @cpp{scheme_malloc} from - Racket's C API), @indexed-racket['atomic] - (@cpp{scheme_malloc_atomic}), @indexed-racket['tagged] - (@cpp{scheme_malloc_tagged}), @indexed-racket['stubborn] - (@cpp{scheme_malloc_stubborn}), @indexed-racket['uncollectable] - (@cpp{scheme_malloc_uncollectable}), @indexed-racket['eternal] - (@cpp{scheme_malloc_eternal}), @indexed-racket['interior] - (@cpp{scheme_malloc_allow_interior}), - @indexed-racket['atomic-interior] - (@cpp{scheme_malloc_atomic_allow_interior}), or - @indexed-racket['raw] (uses the operating system's @cpp{malloc}, - creating a GC-invisible block).} @item{If an additional - @indexed-racket['failok] flag is given, then - @cpp{scheme_malloc_fail_ok} is used to wrap the call.} + what allocation function to use. It should be one of the following: + + @itemlist[ + + @item{@indexed-racket['raw] --- Allocates memory that is outside + the garbage collector's space and is not traced by the garbage + collector (i.e., is treated as holding no pointers to + collectable memory). This memory must be freed with + @racket[free].} + + @item{@indexed-racket['atomic] --- Allocates memory that can be + reclaimed by the garbage collector, is not traced by the + garbage collector, and is initially filled with zeros. + + For the @3m[] and @CGC[] Racket variants, this allocation mode corresponds + to @cpp{scheme_malloc_atomic} in the C API.} + + @item{@indexed-racket['nonatomic] --- Allocates memory that can + be reclaimed by the garbage collector, is treated by the + garbage collector as holding only pointers, and is initially + filled with zeros. + + For the @3m[] and @CGC[] Racket variants, this allocation mode corresponds + to @cpp{scheme_malloc} in the C API. + + For the @CS[] Racket variant, this mode is of limited use, + because a pointer allocated this way cannot be passed to + foreign functions that expect a pointer to pointers. The result + can only be used with functions like @racket[ptr-set!] and + @racket[ptr-ref].} + + @item{@indexed-racket['atomic-interior] --- Like + @racket['atomic], but the allocated object will not be moved by + the garbage collector as long as the allocated object is + sufficiently retained as described below. + + For the @3m[] and @CGC[] Racket variants, ``sufficiently retained'' + means that the garbage collector does not collect the allocated + object because some pointer (that is visible to the collector) + refers to the object. Furthermore, that reference can point to + the interior of the object, insteda of its starting address. + This allocation mode corresponds to + @cpp{scheme_malloc_atomic_allow_interior} in the C API. + + For the @CS[] Racket variant, ``sufficiently retained'' means that the + specific C pointer object returned by @racket[malloc] remains + accessible. Note that casting the pointer via @racket[cast], for example, + generates a new pointer object which would not by itself + prevent the result of @racket[malloc] from moving, even though + a reference to the same memory could prevent the object from + being reclaimed.} + + @item{@indexed-racket['nonatomic-interior] --- Like + @racket['nonatomic], but the allocated object will not be moved + by the garbage collector as long as the allocated object is + retained. + + This mode is supported only for the @3m[] and @CGC[] Racket variants, and + it corresponds to @cpp{scheme_malloc_allow_interior} in the C + API.} + + @item{@indexed-racket['tagged] --- Allocates memory that must + start with a @tt{short} value that is registered as a tag with + the garbage collector. + + This mode is supported only for the @3m[] and @CGC[] Racket variants, and + it corresponds to @cpp{scheme_malloc_tagged} in the C API.} + + @item{@indexed-racket['stubborn] --- Like @racket['nonatomic], + but supports a hint to the GC via @racket[end-stubborn-change] + after all changes to the object have been made. + + This mode is supported only for the @3m[] and @CGC[] Racket variants, and + it corresponds to @cpp{scheme_malloc_stubborn} in the C API.} + + @item{@indexed-racket['eternal] --- Like @racket['raw], except the + allocated memory cannot be freed. + + This mode is supported only for the @CGC[] Racket variant, and + it corresponds to @cpp{scheme_malloc_uncollectable} in the C API.} + + @item{@indexed-racket['uncollectable] --- Allocates memory that is + never collected, cannot be freed, and potentially contains + pointers to collectable memory. + + This mode is supported only for the @CGC[] Racket variant, and + it corresponds to @cpp{scheme_malloc_uncollectable} in the C API.} + + ]} + + @item{If an additional @indexed-racket['failok] flag is given, then + some effort may be made to detect an allocation failure and + raise @racket[exn:fail:out-of-memory] instead of crashing.} ] diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/foreign/port.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/foreign/port.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/foreign/port.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/foreign/port.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -51,7 +51,7 @@ For any kind of result port, closing the resulting ports readies and unregisters any semaphores for the file descriptor or socket that were -previously created with @racket[unsafe-file-descriptor->semaphore] +previously created with @racket[unsafe-file-descriptor->semaphore] or @racket[unsafe-socket->semaphore].} @@ -75,13 +75,30 @@ (or/c semaphore? #f)] )]{ -For @racket[mode] as @racket['read] or @racket['write], returns a -semaphore that becomes ready when @racket[fd] or @racket[socket] -becomes ready for reading or writing, respectively. The result is -@racket[#f] if a conversion to a semaphore is not supported for the -current platform or for the given file descriptor or socket. +Returns a semaphore that becomes ready when @racket[fd] or @racket[socket] +is ready for reading or writing, as selected by @racket[mode]. Specifically, +these functions provide a one-shot, @emph{edge-triggered} indicator; the +semaphore is posted the @emph{first time} any of the following cases holds: -The @racket['read-check] and @racket['write-check] modes are like +@itemlist[ + +@item{@racket[fd] or @racket[socket] is ready for reading or writing +(depending on @racket[mode]),} + +@item{ports were created from @racket[fd] or @racket[socket] using +@racket[unsafe-file-descriptor->port] or @racket[unsafe-socket->port], +and those ports were closed, or} + +@item{a subsequent call occurred with the same @racket[fd] or +@racket[socket] and with @racket['remove] for @racket[mode].} + +] + +The result is @racket[#f] if a conversion to a semaphore is not +supported for the current platform or for the given file descriptor or +socket. + +The @racket['check-read] and @racket['check-write] modes are like @racket['read] and @racket['write], but the result if @racket[#f] if a semaphore is not already generated for the specified file descriptor or socket in the specified mode. @@ -92,3 +109,42 @@ Beware that closing a port from @racket[unsafe-file-descriptor->port] or @racket[unsafe-socket->port] will also ready and unregister semaphores.} + + +@defproc[(unsafe-fd->evt [fd exact-integer?] + [mode (or/c 'read 'write 'check-read 'check-write 'remove)] + [socket? any/c #t]) + (or/c evt? #f)]{ + +Returns an event that is ready when @racket[fd] is ready for reading +or writing, as selected by @racket[mode]. Specifically, it returns a +multi-use, @emph{level-triggered} indicator; the event is ready +@emph{whenever} any of the following cases holds: + +@itemlist[ + +@item{@racket[fd] is ready for reading or writing (depending on +@racket[mode]),} + +@item{a subsequent call occurred with the same @racket[fd] and with +@racket['remove] for @racket[mode] (once removed, the event is +perpetually ready).} + +] + +The synchronization result of the event is the event itself. + +The @racket['check-read] and @racket['check-write] modes are like +@racket['read] and @racket['write], but the result is @racket[#f] if +an event is not already generated for the specified file descriptor or +socketin the specified mode. + +The @racket['remove] mode readies and unregisters any events +previously created for the given file descriptor or socket. Events +must be unregistered before the file descriptor or socket is +closed. Unlike @racket[unsafe-file-descriptor->semaphore] and +@racket[unsafe-socket->semaphore], closing a port from +@racket[unsafe-file-descriptor->port] or @racket[unsafe-socket->port] +does not unregister events. + +@history[#:added "7.2.0.6"]} diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/foreign/schedule.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/foreign/schedule.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/foreign/schedule.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/foreign/schedule.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -46,6 +46,17 @@ register wakeup triggers.} +@defproc[(unsafe-poll-fd [fd exact-integer?] + [mode '(read write)] + [socket? any/c #t]) + boolean?]{ + +Checks whether the given file descriptor or socket is currently ready +for reading or writing, as selected by @racket[mode]. + +@history[#:added "7.2.0.6"]} + + @defproc[(unsafe-poll-ctx-fd-wakeup [wakeups any/c] [fd fixnum?] [mode '(read write error)]) diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/foreign/types.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/foreign/types.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/foreign/types.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/foreign/types.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -564,8 +564,8 @@ @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 + value of @racket[blocking?] affects only the @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 @@ -1711,7 +1711,7 @@ corresponding integers, counting from @racket[0]. To call a foreign function that takes an enum as a parameter simply provide -the symbol of the desiered enum as an argument. +the symbol of the desired enum as an argument. @racketblock[ (code:comment "example sdl call") diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/foreign/utils.rkt racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/foreign/utils.rkt --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/foreign/utils.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/foreign/utils.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -19,6 +19,7 @@ reference.scrbl ->> tech-place + 3m CGC CS (all-from-out scribble/manual) (for-label (all-from-out racket/base racket/contract @@ -44,3 +45,7 @@ (define (tech-place) (tech "place" #:doc '(lib "scribblings/reference/reference.scrbl"))) + +(define (CGC) (tech #:doc guide.scrbl "CGC")) +(define (3m) (tech #:doc guide.scrbl "3m")) +(define (CS) (tech #:doc guide.scrbl "CS")) diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/guide/contracts/general-function.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/guide/contracts/general-function.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/guide/contracts/general-function.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/guide/contracts/general-function.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -12,8 +12,7 @@ @ctc-section[#:tag "optional"]{Optional Arguments} -Take a look at this excerpt from a string-processing module, inspired by the -@link["http://schemecookbook.org"]{Scheme cookbook}: +Take a look at this excerpt from a string-processing module: @racketmod[ racket diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/guide/guide-utils.rkt racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/guide/guide-utils.rkt --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/guide/guide-utils.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/guide/guide-utils.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -9,7 +9,7 @@ (require (for-label racket/base)) (provide (for-label (all-from-out racket/base))) -(provide Quick Racket HtDP +(provide Quick Racket HtDP inside-doc tool moreguide guideother @@ -66,6 +66,7 @@ (define Racket (other-manual '(lib "scribblings/reference/reference.scrbl"))) +(define inside-doc '(lib "scribblings/inside/inside.scrbl")) + (define r6rs @elem{R@superscript{6}RS}) (define r5rs @elem{R@superscript{5}RS}) - diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/guide/match.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/guide/match.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/guide/match.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/guide/match.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -92,6 +92,24 @@ [_ 'something-else]) ] +Note that the identifier @racket[else] is @bold{not} a reserved catch-all (like @racket[_]). +If @racket[else] appears in a pattern then its binding from +@racketmodname[racket/base] may be shadowed, and this can cause problems with +@racket[cond] and @racket[case]. + +@interaction[ +#:eval match-eval +(match 1 + [else + (case 2 + [(a 1 b) 3] + [else 4])]) +(match #f + [else + (cond + [#f 'not-evaluated] + [else 'also-not-evaluated])]) +] An ellipsis, written @litchar{...}, acts like a Kleene star within a list or vector pattern: the preceding sub-pattern can be used to match diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/guide/pattern-macros.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/guide/pattern-macros.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/guide/pattern-macros.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/guide/pattern-macros.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -120,9 +120,9 @@ @racketblock[ (let ([set!_1 5] [other 6]) - (let ([tmp_1 set!_1]) + (let ([tmp set!_1]) (set! set!_1 other) - (set! other tmp_1)) + (set! other tmp)) (list set!_1 other)) ] diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/guide/performance.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/guide/performance.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/guide/performance.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/guide/performance.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -20,7 +20,7 @@ underlying computing machinery can be quite large. In this chapter, we narrow the gap by explaining details of the -Racket compiler and run-time system and how they affect the run-time +Racket compiler and runtime system and how they affect the runtime and memory performance of Racket code. @; ---------------------------------------------------------------------- @@ -50,17 +50,63 @@ @; ---------------------------------------------------------------------- +@section[#:tag "virtual-machines"]{Racket Virtual Machine Implementations} + +Racket is available in three implementation variants: @deftech{3m}, +@deftech{CGC}, and @deftech{CS}: + +@itemlist[ + + @item{@tech{3m} is the current default implementation, so it's + probably the one that you're using. + + For this variant, @racket[(system-type 'vm)] reports + @racket['racket] and @racket[(system-type 'gc)] reports + @racket['3m].} + + @item{@tech{CGC} is an older variant. It's the same basic + implementation as @tech{3m} (i.e., the same virtual machine), + but compiled to rely on a ``conservative'' garbage collector, + which affects the way that Racket interacts with C code. (See + @secref["CGC versus 3m" #:doc inside-doc] in + @other-manual[inside-doc] for more information.) + + For this variant, @racket[(system-type 'vm)] reports + @racket['racket] and @racket[(system-type 'gc)] reports + @racket['cgc].} + + @item{@tech{CS} is a newer implementation that builds on + @hyperlink["https://www.scheme.com/"]{Chez Scheme} as its core + virtual machine. This implementation performs better for some + programs, and it is likely to improve and eventually replace + the @tech{3m} implementation as the default. + + For this variant, @racket[(system-type 'vm)] reports + @racket['chez-scheme] and @racket[(system-type 'gc)] reports + @racket['cs].} + +] + +In general, Racket programs should run the same in all variants. +Furthermore, the performance characteristics of Racket program should +be similar in the @tech{3m} and @tech{CS} variants. The cases where a +program may depends on the variant will typically involve interactions +with foreign libraries; in particular, the Racket C API described in +@other-doc[inside-doc] is available only for the virtual machine of +the @tech{3m} and @tech{CGC} variants. + +@; ---------------------------------------------------------------------- + @section[#:tag "JIT"]{The Bytecode and Just-in-Time (JIT) Compilers} Every definition or expression to be evaluated by Racket is compiled -to an internal bytecode format. In interactive mode, this compilation -occurs automatically and on-the-fly. Tools like @exec{raco make} and +to an internal bytecode format, although ``bytecode'' may actually be +native machine code. In interactive mode, this compilation occurs +automatically and on-the-fly. Tools like @exec{raco make} and @exec{raco setup} marshal compiled bytecode to a file, so that you do -not have to compile from source every time that you run a -program. (Most of the time required to compile a file is actually in -macro expansion; generating bytecode from fully expanded code is -relatively fast.) See @secref["compile"] for more information on -generating bytecode files. +not have to compile from source every time that you run a program. +See @secref["compile"] for more information on generating +bytecode files. The bytecode compiler applies all standard optimizations, such as constant propagation, constant folding, inlining, and dead-code @@ -68,14 +114,25 @@ usual binding, the expression @racket[(let ([x 1] [y (lambda () 4)]) (+ 1 (y)))] is compiled the same as the constant @racket[5]. -On some platforms, bytecode is further compiled to native code via a -@deftech{just-in-time} or @deftech{JIT} compiler. The @tech{JIT} -compiler substantially speeds programs that execute tight loops, -arithmetic on small integers, and arithmetic on inexact real -numbers. Currently, @tech{JIT} compilation is supported for x86, -x86_64 (a.k.a. AMD64), ARM, and 32-bit PowerPC processors. The @tech{JIT} -compiler can be disabled via the @racket[eval-jit-enabled] parameter -or the @DFlag{no-jit}/@Flag{j} command-line flag for @exec{racket}. +For the @tech{CS} variant of Racket, the main bytecode format is +non-portable machine code. For the @tech{3m} and @tech{CGC} variants +of Racket, bytecode is portable in the sense that it is +machine-independent. Setting @racket[current-compile-target-machine] +to @racket[#f] selects a separate machine-independent and +variant-independent format on all Racket variants, but running code in +that format requires an additional internal conversion step to the +variant's main bytecode format. + +Machine-independent bytecode for @tech{3m} or @tech{CGC} is further +compiled to native code via a @deftech{just-in-time} or @deftech{JIT} +compiler. The @tech{JIT} compiler substantially speeds programs that +execute tight loops, arithmetic on small integers, and arithmetic on +inexact real numbers. Currently, @tech{JIT} compilation is supported +for x86, x86_64 (a.k.a. AMD64), ARM, and 32-bit PowerPC processors. +The @tech{JIT} compiler can be disabled via the +@racket[eval-jit-enabled] parameter or the @DFlag{no-jit}/@Flag{j} +command-line flag for @exec{racket}. Setting @racket[eval-jit-enabled] +to @racket[#f] has not effect on the @tech{CS} variant of Racket. The @tech{JIT} compiler works incrementally as functions are applied, but the @tech{JIT} compiler makes only limited use of run-time @@ -93,8 +150,7 @@ The module system aids optimization by helping to ensure that identifiers have the usual bindings. That is, the @racket[+] provided by @racketmodname[racket/base] can be recognized by the compiler and -inlined, which is especially important for @tech{JIT}-compiled code. -In contrast, in a traditional interactive Scheme system, the top-level +inlined. In contrast, in a traditional interactive Scheme system, the top-level @racket[+] binding might be redefined, so the compiler cannot assume a fixed @racket[+] binding (unless special flags or declarations are used to compensate for the lack of a module system). @@ -111,7 +167,7 @@ environment. Although this optimization within modules is important for performance, it hinders some forms of interactive development and exploration. The @racket[compile-enforce-module-constants] parameter -disables the @tech{JIT} compiler's assumptions about module +disables the compiler's assumptions about module definitions when interactive exploration is more important. See @secref["module-set"] for more information. @@ -179,7 +235,7 @@ of the function. Primitive operations like @racket[pair?], @racket[car], and -@racket[cdr] are inlined at the machine-code level by the @tech{JIT} +@racket[cdr] are inlined at the machine-code level by the bytecode or @tech{JIT} compiler. See also the later section @secref["fixnums+flonums"] for information about inlined arithmetic operations. @@ -298,7 +354,7 @@ correspond to 64-bit IEEE floating-point numbers on all platforms. Inlined fixnum and flonum arithmetic operations are among the most -important advantages of the @tech{JIT} compiler. For example, when +important advantages of the compiler. For example, when @racket[+] is applied to two arguments, the generated machine code tests whether the two arguments are fixnums, and if so, it uses the machine's instruction to add the numbers (and check for overflow). If @@ -321,7 +377,8 @@ The @racketmodname[racket/flonum] library provides flonum-specific operations, and combinations of flonum operations allow the @tech{JIT} -compiler to generate code that avoids boxing and unboxing intermediate +compiler for the @tech{3m} and @tech{CGC} variants of Racket +to generate code that avoids boxing and unboxing intermediate results. Besides results within immediate combinations, flonum-specific results that are bound with @racket[let] and consumed by a later flonum-specific operation are unboxed within temporary @@ -366,7 +423,7 @@ @section[#:tag "ffi-pointer-access"]{Foreign Pointers} The @racketmodname[ffi/unsafe] library provides functions for unsafely -reading and writing arbitrary pointer values. The JIT recognizes uses +reading and writing arbitrary pointer values. The compiler recognizes uses of @racket[ptr-ref] and @racket[ptr-set!] where the second argument is a direct reference to one of the following built-in C types: @racket[_int8], @racket[_int16], @racket[_int32], @racket[_int64], @@ -378,10 +435,9 @@ The bytecode compiler will optimize references to integer abbreviations like @racket[_int] to C types like @racket[_int32]---where the representation sizes are constant across -platforms---so the JIT can specialize access with those C types. C +platforms---so the compiler can specialize access with those C types. C types such as @racket[_long] or @racket[_intptr] are not constant -across platforms, so their uses are currently not specialized by the -JIT. +across platforms, so their uses are not as consistently specialized. Pointer reads and writes using @racket[_float] or @racket[_double] are not currently subject to unboxing optimizations. @@ -421,16 +477,16 @@ @section[#:tag "gc-perf"]{Memory Management} -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, +The @tech{3m} (default) and @tech{CS} Racket +@seclink["virtual-machines"]{virtual machines} each 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 @tech{3m} variant is currently the standard one. +Racket memory management. Although memory allocation is reasonably cheap, avoiding allocation -altogether is normally faster. One particular place where allocation +altogether is often faster. One particular place where allocation can be avoided sometimes is in @deftech{closures}, which are the run-time representation of functions that contain free variables. For example, diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/guide/phases.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/guide/phases.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/guide/phases.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/guide/phases.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -19,7 +19,7 @@ a module to exist in the same process but separated by phase. Racket enforces @emph{separation} of such phases, where different phases cannot communicate in any way other than via the protocol of macro expansion, -where the output of one phases is the code used in the next. +where the output of one phase is the code used in the next. @section{Phases and Bindings} diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/guide/regexp.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/guide/regexp.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/guide/regexp.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/guide/regexp.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -51,7 +51,7 @@ @litchar{"}.} If we needed to match the character @litchar{.} itself, we can escape -it by precede it with a @litchar{\}. The character sequence +it by preceding it with a @litchar{\}. The character sequence @litchar{\.} is thus a @tech{metasequence}, since it doesn't match itself but rather just @litchar{.}. So, to match @litchar{a}, @litchar{.}, and @litchar{c} in succession, we use the regexp pattern diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/inside/inside.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/inside/inside.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/inside/inside.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/inside/inside.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -6,8 +6,11 @@ @author["Matthew Flatt"] -This manual describes the C interface of Racket's run-time system. The -C interface is relevant primarily when interacting with foreign +This manual describes the C interface of Racket's runtime system for +the 3m and CGC variants of Racket (but not the CS variant; see +@secref[#:doc '(lib "scribblings/guide/guide.scrbl") +"virtual-machines"]). The C +interface is relevant primarily when interacting with foreign libraries as described in @other-manual['(lib "scribblings/foreign/foreign.scrbl")]; even though interactions with foreign code are constructed in pure Racket using the diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/inside/memory.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/inside/memory.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/inside/memory.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/inside/memory.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -671,7 +671,7 @@ [size_t n])]{ Allocates @var{n} bytes of collectable memory, initially filled with -zeros. In 3m, the allocated object is treated as an array of +zeros. The allocated object is treated as an array of pointers.} @function[(void* scheme_malloc_atomic @@ -747,7 +747,7 @@ [size_t size])]{ Attempts to allocate @var{size} bytes using @var{mallocf}. If the -allocation fails, the @racket[exn:misc:out-of-memory] exception is +allocation fails, the @racket[exn:fail:out-of-memory] exception is raised.} @function[(void** scheme_malloc_immobile_box diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/raco/setup.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/raco/setup.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/raco/setup.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/raco/setup.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -161,6 +161,12 @@ @envvar{PLT_COMPILED_FILE_CHECK} environment variable is set to @litchar{exists}, in which case timestamps are ignored).} + @item{@DFlag{recompile-only} --- disallow recompilation of modules + from source, imposing the constraint that each @filepath{.zo} file + is up-to-date, needs only a timestamp adjustment, or can be + recompiled from an existing @filepath{.zo} in machine-independent + format (when compiling to a machine-dependent format).} + @item{@DFlag{no-launcher} or @Flag{x} --- refrain from creating executables or installing @tt{man} pages (as specified in @filepath{info.rkt}; see @secref["setup-info"]).} @@ -273,6 +279,19 @@ @item{@DFlag{fail-fast} --- attempt to break as soon as any error is discovered.} + @item{@DFlag{error-out} @nonterm{file} --- handle survivable errors + by writing @nonterm{file} and exiting as successful, which + facilitates chaining multiple @exec{raco setup} invocations in + combination with @DFlag{error-in}. If there are no errors and + @nonterm{file} already exists, it is deleted.} + + @item{@DFlag{error-in} @nonterm{file} --- treat the existence of + @nonterm{file} as a ``errors were reported by a previous process'' + error. Typically, @nonterm{file} is created by previous @exec{raco + setup} run using @DFlag{error-out}. A file for @DFlag{error-in} is + detected before creating a file via @DFlag{error-out}, so the same + file can be used to chain a sequence of @exec{raco setup} steps.} + @item{@DFlag{pause} or @Flag{p} --- pause for user input if any errors are reported (so that a user has time to inspect output that might otherwise disappear when the @exec{raco setup} process ends).} @@ -337,7 +356,9 @@ #:changed "6.1.1" @elem{Added the @DFlag{force-user-docs} flag.} #:changed "6.1.1.6" @elem{Added the @DFlag{only-foreign-libs} flag.} #:changed "6.6.0.3" @elem{Added support for @envvar{PLT_COMPILED_FILE_CHECK}.} - #:changed "7.0.0.19" @elem{Added @DFlag{places} and @DFlag{processes}.}] + #:changed "7.0.0.19" @elem{Added @DFlag{places} and @DFlag{processes}.} + #:changed "7.2.0.7" @elem{Added @DFlag{error-in} and @DFlag{error-out}.} + #:changed "7.2.0.8" @elem{Added @DFlag{recompile-only}.}] @; ------------------------------------------------------------------------ @@ -921,6 +942,7 @@ @defproc[(setup [#:file file (or/c #f path-string?) #f] [#:collections collections (or/c #f (listof (listof path-string?))) #f] + [#:pkgs pkgs (or/c #f (listof string?)) #f] [#:planet-specs planet-specs (or/c #f (listof (list/c string? string? @@ -932,8 +954,12 @@ [#:make-docs? make-docs? any/c #t] [#:make-doc-index? make-doc-index? any/c #f] [#:force-user-docs? force-user-docs? any/c #f] + [#:check-pkg-deps? check-pkg-deps? any/c #f] + [#:fix-pkg-deps? fix-pkg-deps? any/c #f] + [#:unused-pkg-deps? unused-pkg-deps? any/c #f] [#:clean? clean? any/c #f] [#:tidy? tidy? any/c #f] + [#:recompile-only? recompile-only? any/c #f] [#:jobs jobs exact-nonnegative-integer? #f] [#:fail-fast? fail-fast? any/c #f] [#:get-target-dir get-target-dir (or/c #f (-> path-string?)) #f]) @@ -946,10 +972,16 @@ a @filepath{.plt} archive.} @item{@racket[collections] --- if not @racket[#f], constrains setup to - the named collections, along with @racket[planet-specs], if any} + the named collections (along with @racket[pkgs] and + @racket[planet-specs], if any)} + + @item{@racket[pkgs] --- if not @racket[#f], constrains setup to the + named packages (along with @racket[collections] and + @racket[planet-specs], if any)} @item{@racket[planet-spec] --- if not @racket[#f], constrains setup to - the named @|PLaneT| packages, along with @racket[collections], if any} + the named @|PLaneT| packages (along with @racket[collections] and + @racket[pkgs], if any)} @item{@racket[make-user?] --- if @racket[#f], disables any user-specific setup actions} @@ -968,12 +1000,28 @@ documentation, creates a user-specific documentation entry point even if it has the same content as the installation} + @item{@racket[check-pkg-deps?] --- if true, enables + package-dependency checking even when @racket[collections], + @racket[pkgs], or @racket[planet-specs] is non-@racket[#f].} + + @item{@racket[fix-pkg-deps?] --- if true, implies + @racket[check-pkg-deps?] and attempts to automatically correct + discovered package-dependency problems} + + @item{@racket[unused-pkg-deps?] --- if true, implies + @racket[check-pkg-deps?] and also reports dependencies that + appear to be unused} + @item{@racket[clean?] --- if true, enables cleaning mode instead of setup mode} @item{@racket[tidy?] --- if true, enables global tidying of documentation and metadata indexes even when @racket[collections] or @racket[planet-specs] is non-@racket[#f]} + @item{@racket[recompile-only?] --- if true, disallows compilation + from source, allowing only timestamp adjustments and recompilation + from machine-independent form} + @item{@racket[jobs] --- if not @racket[#f], determines the maximum number of parallel tasks used for setup} @@ -992,7 +1040,11 @@ sensitive to the @racket[use-compiled-file-check] parameter. @history[#:changed "6.1" @elem{Added the @racket[fail-fast?] argument.} - #:changed "6.1.1" @elem{Added the @racket[force-user-docs?] argument.}]} + #:changed "6.1.1" @elem{Added the @racket[force-user-docs?] argument.} + #:changed "7.2.0.7" @elem{Added the @racket[check-pkg-deps?], + @racket[fix-pkg-deps?] , and @racket[unused-pkg-deps?] + arguments.} + #:changed "7.2.0.8" @elem{Added the @racket[recompile-only?] argument.}]} diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/booleans.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/booleans.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/booleans.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/booleans.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -55,12 +55,14 @@ @examples[ (equal? 'yes 'yes) (equal? 'yes 'no) +(equal? (* 6 7) 42) (equal? (expt 2 100) (expt 2 100)) (equal? 2 2.0) (let ([v (mcons 1 2)]) (equal? v v)) (equal? (mcons 1 2) (mcons 1 2)) (equal? (integer->char 955) (integer->char 955)) (equal? (make-string 3 #\z) (make-string 3 #\z)) +(equal? #t #t) ]} @@ -81,29 +83,35 @@ @examples[ (eqv? 'yes 'yes) (eqv? 'yes 'no) +(eqv? (* 6 7) 42) (eqv? (expt 2 100) (expt 2 100)) (eqv? 2 2.0) (let ([v (mcons 1 2)]) (eqv? v v)) (eqv? (mcons 1 2) (mcons 1 2)) (eqv? (integer->char 955) (integer->char 955)) (eqv? (make-string 3 #\z) (make-string 3 #\z)) +(eqv? #t #t) ]} @defproc[(eq? [v1 any/c] [v2 any/c]) boolean?]{ Return @racket[#t] if @racket[v1] and @racket[v2] refer to the same -object, @racket[#f] otherwise. See also @secref["model-eq"]. +object, @racket[#f] otherwise. As a special case among @tech{numbers}, +two @tech{fixnums} that are @racket[=] are also the same according +to @racket[eq?]. See also @secref["model-eq"]. @examples[ (eq? 'yes 'yes) (eq? 'yes 'no) +(eq? (* 6 7) 42) (eq? (expt 2 100) (expt 2 100)) (eq? 2 2.0) (let ([v (mcons 1 2)]) (eq? v v)) (eq? (mcons 1 2) (mcons 1 2)) (eq? (integer->char 955) (integer->char 955)) (eq? (make-string 3 #\z) (make-string 3 #\z)) +(eq? #t #t) ]} @@ -144,6 +152,7 @@ (immutable? #(0 1 2 3)) (immutable? (make-hash)) (immutable? (make-immutable-hash '([a b]))) +(immutable? #t) ]} @defthing[gen:equal+hash any/c]{ diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/contracts.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/contracts.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/contracts.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/contracts.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -1,12 +1,13 @@ #lang scribble/doc @(require "mz.rkt") @(require (for-label syntax/modcollapse - racket/stxparam)) + racket/stxparam + racket/serialize)) @(define contract-eval (lambda () (let ([the-eval (make-base-eval)]) - (the-eval '(require racket/contract racket/contract/parametric racket/list)) + (the-eval '(require racket/contract racket/contract/parametric racket/list racket/math)) the-eval))) @(define blame-object @tech{blame object}) @@ -1174,13 +1175,29 @@ must be an integer, and the second argument must be a boolean. The function must produce an integer. +@examples[#:eval (contract-eval) #:once + (define/contract (maybe-invert i b) + (-> integer? boolean? integer?) + (if b (- i) i)) + + (maybe-invert 1 #t) + (eval:error (maybe-invert #f 1))] + A domain specification may include a keyword. If so, the function must accept corresponding (mandatory) keyword arguments, and the values for the keyword arguments must match the corresponding contracts. For example: -@racketblock[(integer? #:x boolean? . -> . integer?)] +@racketblock[(integer? #:invert? boolean? . -> . integer?)] is a contract on a function that accepts a by-position argument that -is an integer and a @racket[#:x] argument that is a boolean. +is an integer and an @racket[#:invert?] argument that is a boolean. + +@examples[#:eval (contract-eval) #:once + (define/contract (maybe-invert i #:invert? b) + (-> integer? #:invert? boolean? integer?) + (if b (- i) i)) + + (maybe-invert 1 #:invert? #t) + (eval:error (maybe-invert 1 #f))] As an example that uses an @racket[...], this contract: @racketblock[(integer? string? ... integer? . -> . any)] @@ -1188,15 +1205,53 @@ the function must be integers (and there must be at least two arguments) and any other arguments must be strings. +@examples[#:eval (contract-eval) #:once + (define/contract (string-length/between? lower-bound s1 . more-args) + (-> integer? string? ... integer? boolean?) + + (define all-but-first-arg-backwards (reverse (cons s1 more-args))) + (define upper-bound (first all-but-first-arg-backwards)) + (define strings (rest all-but-first-arg-backwards)) + (define strings-length + (for/sum ([str (in-list strings)]) + (string-length str))) + (<= lower-bound strings-length upper-bound)) + + (string-length/between? 4 "farmer" "john" 40) + (eval:error (string-length/between? 4 "farmer" 'john 40)) + (eval:error (string-length/between? 4 "farmer" "john" "fourty"))] + If @racket[any] is used as the last sub-form for @racket[->], no contract checking is performed on the result of the function, and thus any number of values is legal (even different numbers on different invocations of the function). +@examples[#:eval (contract-eval) #:once + (define/contract (multiple-xs n x) + (-> natural? any/c any) + (apply + values + (for/list ([_ (in-range n)]) + n))) + + (multiple-xs 4 "four")] + If @racket[(values range-expr ...)] is used as the last sub-form of @racket[->], the function must produce a result for each contract, and each value must match its respective contract. + +@examples[#:eval (contract-eval) #:once + (define/contract (multiple-xs n x) + (-> natural? any/c (values any/c any/c any/c)) + (apply + values + (for/list ([_ (in-range n)]) + n))) + + (multiple-xs 3 "three") + (eval:error (multiple-xs 4 "four"))] + @history[#:changed "6.4.0.5" @list{Added support for ellipses}] } @@ -1785,6 +1840,11 @@ If the @racket[#:omit-constructor] option is present, the constructor is not provided. +Note that if the struct is created with @racket[serializable-struct] +or @racket[define-serializable-struct], @racket[contract-out] does not +protect struct instances that are created via +@racket[deserialize]. Consider using @racket[struct-guard/c] instead. + The @racket[#:∃], @racket[#:exists], @racket[#:∀], and @racket[#:forall] clauses define new abstract contracts. The variables are bound in the remainder of the @racket[contract-out] form to new contracts that hide @@ -1842,6 +1902,19 @@ is evaluated at the position of the @racket[provide/contract] form instead of at the end of the enclosing module.} +@defform[(struct-guard/c contract-expr ...)]{ + Returns a procedure suitable to be passed as the @racket[#:guard] + argument to @racket[struct], @racket[serializable-struct] (and related forms). + The guard procedure ensures that each contract protects the + corresponding field values, as long as the struct is not mutated. + Mutations are not protected. + + @examples[#:eval (contract-eval) #:once + (struct snake (weight hungry?) + #:guard (struct-guard/c real? boolean?)) + (eval:error (snake 1.5 "yep"))] +} + @subsection{Nested Contract Boundaries} @defmodule*/no-declare[(racket/contract/region)] @declare-exporting-ctc[racket/contract/region] @@ -2262,7 +2335,7 @@ missing one party. It must return two values. The first value must be a function that accepts both the value that is getting the contract and the name of the missing blame party, in that order. The second value should - be a collapsible representation of the contract. + be a @tech[#:key "collapsible contract"]{collapsible} representation of the contract. The projection @racket[proj] and @racket[val-first-proj] are older mechanisms for defining the behavior of applying the contract. The @racket[proj] argument @@ -2937,8 +3010,8 @@ but using a different signature. They are here for backwards compatibility.);} @item{@racket[collapsible-late-neg-proj], similar to @racket[late-neg-proj] which produces a blame-tracking projection defining the behavior of the - contract, this function additionally specifies the collapsible behavior - of the contract;} + contract, this function additionally specifies the + @tech[#:key "collapsible contract"]{collapsible} behavior of the contract;} @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 @@ -3517,11 +3590,23 @@ combinators support collapsing for vector contracts and function contracts for functions returning a single value. +Intuitively, a collapsible contract is a tree structure. +The @racketlink[collapsible-ho/c]{tree nodes} represent higher-order contracts + (e.g., @racket[->]) and the @racketlink[collapsible-leaf/c]{tree leaves} + represent sequences of flat contracts. +Two trees can collapse into one tree via the @racket[merge] procedure, + which removes unnecessary flat contracts from the leaves. + +For more information on the motivation and design of collapsible contracts, + see @cite["Feltey18"]. +For the theoretical foundations, see @cite["Greenberg15"]. + @bold{Warning}: the features described in this section are experimental and may not be sufficient to implement new collapsible contracts. Implementing new collapsible contracts requires the use of unsafe chaperones and impersonators which are only supported for vector and procedure values. This documentation exists -primarily to allow future maintenance of the @racket[racket/contract/collapsible] library/ +primarily to allow future maintenance of the @racket[racket/contract/collapsible] +library. @bold{End Warning} @defproc[(get/build-collapsible-late-neg-projection [c contract?]) (-> blame? (values (-> any/c any/c any/c) collapsible-contract?))]{ @@ -3587,7 +3672,7 @@ (-> collapsible-contract? any/c any/c any/c) (λ (cc v neg) (error - "internal error: contract does not support `collapsible-guard`" ctc))]) + "internal error: contract does not support `collapsible-guard`" cc))]) collapsible-contract-property?]{ Constructs a @deftech{collapsible contract property} from a merging function and a guard. The @racket[try-merge] argument is similar to @racket[merge], but may return @racket[#f] instead @@ -3602,7 +3687,7 @@ [latest-ctc contract?])]{ A common parent structure for collapsible contracts for higher-order values. The @racket[latest-blame] field holds the blame object for the most recent - contract attached. Similarly, the @racket[missing-party] filed holds the latest + contract attached. Similarly, the @racket[missing-party] field holds the latest missing party passed to the contract. The @racket[latest-contract] field stores the most recent contract attached to the value. } diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/define-struct.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/define-struct.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/define-struct.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/define-struct.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -180,7 +180,8 @@ not @racket[id], then both @racket[name-id] and @racket[id] are bound to information about the structure type. Only one of @racket[#:extra-name] and @racket[#:name] can be provided within a -@racket[struct] form. +@racket[struct] form, and @racket[#:extra-name] cannot be combined +with @racket[#:omit-define-syntaxes]. @examples[#:eval posn-eval (struct ghost (color name) #:prefab #:extra-name GHOST) diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/eval.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/eval.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/eval.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/eval.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -223,19 +223,28 @@ (Mac OS). The file is loaded using internal, OS-specific primitives. See @other-manual['(lib "scribblings/inside/inside.scrbl")] for more information on -@tech{dynamic extensions}.} +@tech{dynamic extensions}. + +Extensions are supported only when @racket[(system-type 'vm)] returns +@racket['racket].} @defproc[(load-extension [file path-string?]) any]{ Sets @racket[current-load-relative-directory] like @racket[load], and -calls the @tech{extension-load handler} in tail position.} +calls the @tech{extension-load handler} in tail position. + +Extensions are supported only when @racket[(system-type 'vm)] returns +@racket['racket].} @defproc[(load-relative-extension [file path-string?]) any]{ Like @racket[load-extension], but resolves @racket[file] using -@racket[current-load-relative-directory] like @racket[load-relative].} +@racket[current-load-relative-directory] like @racket[load-relative]. + +Extensions are supported only when @racket[(system-type 'vm)] returns +@racket['racket].} @defparam[current-load/use-compiled proc (path? (or/c #f @@ -261,8 +270,8 @@ the default @tech{compiled-load handler} checks for a @filepath{.ss} file.} @item{The default @tech{compiled-load handler} checks for the opportunity - to load from @filepath{.zo} (bytecode) files and - @filepath{.so} (native Unix), @filepath{.dll} (native Windows), + to load from @filepath{.zo} (bytecode) files and, when @racket[(system-type 'vm)] + returns @racket['racket], for @filepath{.so} (native Unix), @filepath{.dll} (native Windows), or @filepath{.dylib} (native Mac OS) files.} @item{When the default @tech{compiled-load handler} needs to load from @@ -290,7 +299,8 @@ @filepath{.zo} version of the file (whose name is formed by passing @racket[_file] and @racket[#".zo"] to @racket[path-add-extension]) is loaded if it exists directly in one of the indicated subdirectories, -or a @filepath{.so}/@filepath{.dll}/@filepath{.dylib} version of the +or when @racket[(system-type 'vm)] returns +@racket['racket], then a @filepath{.so}/@filepath{.dll}/@filepath{.dylib} version of the file is loaded if it exists within a @filepath{native} subdirectory of a @racket[use-compiled-file-paths] directory, in an even deeper subdirectory as named by @racket[system-library-subpath]. A compiled @@ -299,7 +309,8 @@ of @racket['modify-seconds], a compiled file is used only if its modification date is not older than the date for @racket[_file]. If both @filepath{.zo} and -@filepath{.so}/@filepath{.dll}/@filepath{.dylib} files are available, +@filepath{.so}/@filepath{.dll}/@filepath{.dylib} files are available +when @racket[(system-type 'vm)] returns @racket['racket], the @filepath{.so}/@filepath{.dll}/@filepath{.dylib} file is used. If @racket[_file] ends with @filepath{.rkt}, no such file exists, the handler's second argument is a symbol, and a @filepath{.ss} file @@ -626,11 +637,12 @@ A @tech{parameter} that determines whether the native-code just-in-time compiler (@deftech{JIT}) is enabled for code (compiled or not) that is passed to the default evaluation handler. A true parameter value is effective -only on platforms for which the JIT is supported, and changing the value -from its initial setting affects only forms that are outside of @racket[module]. +only on platforms for which the JIT is supported and for Racket virtual machines +that rely on a JIT. The default is @racket[#t], unless the JIT is not supported by the -current platform, unless it is disabled through the +current platform but is supported on the same virtual machine for other +platforms, unless it is disabled through the @Flag{j}/@DFlag{no-jit} command-line flag to stand-alone Racket (or GRacket), and unless it is disabled through the @as-index{@envvar{PLTNOMZJIT}} environment variable (set to any diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/exns.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/exns.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/exns.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/exns.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -106,9 +106,9 @@ (eval:error (raise 'failed #t)) ]} -@defproc*[([(error [sym symbol?]) any] - [(error [msg string?] [v any/c] ...) any] - [(error [src symbol?] [format string?] [v any/c] ...) any])]{ +@defproc*[([(error [message-sym symbol?]) any] + [(error [message-str string?] [v any/c] ...) any] + [(error [who-sym symbol?] [format-str string?] [v any/c] ...) any])]{ Raises the exception @racket[exn:fail], which contains an error string. The different forms produce the error string in different @@ -116,23 +116,23 @@ @itemize[ - @item{@racket[(error sym)] creates a message string by concatenating - @racket["error: "] with the string form of @racket[sym]. Use this + @item{@racket[(error message-sym)] creates a message string by concatenating + @racket["error: "] with the string form of @racket[message-sym]. Use this form sparingly.} - @item{@racket[(error msg v ...)] creates a message string by - concatenating @racket[msg] with string versions of the @racket[v]s + @item{@racket[(error message-str v ...)] creates a message string by + concatenating @racket[message-str] with string versions of the @racket[v]s (as produced by the current error value conversion handler; see @racket[error-value->string-handler]). A space is inserted before each @racket[v]. Use this form sparingly, because it does not conform well to Racket's @tech{error message conventions}; consider @racket[raise-arguments-error], instead. } - @item{@racket[(error src frmat v ...)] creates a + @item{@racket[(error who-sym format-str v ...)] creates a message string equivalent to the string created by @racketblock[ - (format (string-append "~s: " frmat) src v ...) + (format (string-append "~s: " format-str) who-sym v ...) ] When possible, use functions such as @racket[raise-argument-error], @@ -151,9 +151,9 @@ ]} -@defproc*[([(raise-user-error [sym symbol?]) any] - [(raise-user-error [msg string?] [v any/c] ...) any] - [(raise-user-error [src symbol?] [format string?] [v any/c] ...) any])]{ +@defproc*[([(raise-user-error [message-sym symbol?]) any] + [(raise-user-error [message-str string?] [v any/c] ...) any] + [(raise-user-error [who-sym symbol?] [format-str string?] [v any/c] ...) any])]{ Like @racket[error], but constructs an exception with @racket[make-exn:fail:user] instead of @racket[make-exn:fail]. The diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/hashes.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/hashes.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/hashes.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/hashes.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -55,7 +55,12 @@ Two hash tables cannot be @racket[equal?] unless they use the same key-comparison procedure (@racket[equal?], @racket[eqv?], or @racket[eq?]), both hold keys strongly or weakly, and have the same -mutability. +mutability. Empty immutable hash tables are @racket[eq?] when they +are @racket[equal?]. + +@history[#:changed "7.2.0.9" @elem{Made empty immutable hash tables + @racket[eq?] when they are + @racket[equal?].}] @elemtag['(caveat "concurrency")]{@bold{Caveats concerning concurrent modification:}} A mutable hash table can be manipulated with diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/linklet.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/linklet.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/linklet.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/linklet.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -120,7 +120,8 @@ [name any/c #f] [import-keys #f #f] [get-import #f #f] - [options (listof (or/c 'serializable 'unsafe 'static 'no-prompt)) + [options (listof (or/c 'serializable 'unsafe 'static + 'use-prompt 'uninterned-literal)) '(serializable)]) linklet?] [(compile-linklet [form (or/c correlated? any/c)] @@ -129,7 +130,8 @@ [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 'no-prompt)) + [options (listof (or/c 'serializable 'unsafe 'static + 'use-prompt 'uninterned-literal)) '(serializable)]) (values linklet? vector?)])]{ @@ -192,32 +194,44 @@ the performance of references within the linklet to defined and imported variables. -If @racket['no-prompt] is included in @racket[options], then when the -resulting linklet is instantiated, the @racket[_use-prompt?] argument -to @racket[instantiate-linklet] may be treated as @racket[#f]. +If @racket['use-prompt] is included in @racket[options], then +instantiating resulting linklet always wraps a prompt around each +definition and immediate expression in the linklet. Otherwise, +supplying @racket[#t] as the @racket[_use-prompt?] argument to +@racket[instantiate-linklet] may only wrap a prompt around the entire +instantiation. + +If @racket['uninterned-literal] is included in @racket[options], then +literals in @racket[form] will not necessarily be interned via +@racket[datum-intern-literal] when compiling or loading the linklet. +Disabling the use of @racket[datum-intern-literal] can be especially +useful of the linklet includes a large string or byte string constant +that is not meant to be shared. The symbols in @racket[options] must be distinct, otherwise @exnraise[exn:fail:contract]. -@history[#:changed "7.1.0.8" @elem{Added the @racket['no-prompt] option.}]} +@history[#:changed "7.1.0.8" @elem{Added the @racket['use-prompt] option.} + #:changed "7.1.0.10" @elem{Added the @racket['uninterned-literal] option.}]} @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))] - [options (listof (or/c 'serializable 'unsafe 'static 'no-prompt)) + [get-import #f #f] + [options (listof (or/c 'serializable 'unsafe 'static + 'use-prompt 'uninterned-literal)) '(serializable)]) linklet?] [(recompile-linklet [linklet linklet?] [name any/c] [import-keys vector?] - [get-import (any/c . -> . (values (or/c linklet? #f) - (or/c vector? #f))) + [get-import (or/c (any/c . -> . (values (or/c linklet? #f) + (or/c vector? #f))) + #f) (lambda (import-key) (values #f #f))] - [options (listof (or/c 'serializable 'unsafe 'static 'no-prompt)) + [options (listof (or/c 'serializable 'unsafe 'static + 'use-prompt 'uninterned-literal)) '(serializable)]) (values linklet? vector?)])]{ @@ -225,7 +239,8 @@ and potentially optimizes it further. @history[#:changed "7.1.0.6" @elem{Added the @racket[options] argument.} - #:changed "7.1.0.8" @elem{Added the @racket['no-prompt] option.}]} + #:changed "7.1.0.8" @elem{Added the @racket['use-prompt] option.} + #:changed "7.1.0.10" @elem{Added the @racket['uninterned-literal] option.}]} @defproc[(eval-linklet [linklet linklet?]) linklet?]{ @@ -267,9 +282,13 @@ 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.} +If @racket[use-prompt?] is true, then a a @tech{prompt} is wrapped +around the linklet instantiation in same ways as an expression in a +module body. If the linklet contains multiple definitions or immediate +expressions, then a prompt may or may not be wrapped around each +definition or expression; supply @racket['use-prompt] to +@racket[compile-linklet] to ensure that a prompt is used around each +definition and expression.} @defproc[(linklet-import-variables [linklet linklet?]) @@ -500,7 +519,8 @@ (or/c exact-nonnegative-integer? #f) (or/c exact-positive-integer? #f) (or/c exact-nonnegative-integer? #f))) - #f]) + #f] + [prop (or/c correlated? #f)]) correlated?] @defproc*[([(correlated-property [stx correlated?] [key any/c] @@ -523,4 +543,7 @@ 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.} +@tech{correlated objects} and convert them to plain S-expressions. + +@history[#:changed "7.6.0.6" @elem{Added the @racket[prop] argument + to @racket[datum->correlated].}]} diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/logging.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/logging.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/logging.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/logging.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -160,7 +160,7 @@ [level log-level/c] [topic (or/c symbol? #f) (logger-name logger)] [message string?] - [data any/c] + [data any/c #f] [prefix-message? any/c #t]) void?]{ @@ -174,7 +174,8 @@ @racket[#f], then @racket[message] is prefixed with the topic followed by @racket[": "] before it is sent to receivers. -@history[#:changed "6.0.1.10" @elem{Added the @racket[prefix-message?] argument.}]} +@history[#:changed "6.0.1.10" @elem{Added the @racket[prefix-message?] argument.} + #:changed "7.2.0.7" @elem{Made the @racket[data] argument optional.}]} @defproc[(log-level? [logger logger?] diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/match.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/match.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/match.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/match.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -90,8 +90,10 @@ @item{@racket[_id] (excluding the reserved names @racketidfont{_}, @racketidfont{...}, @racketidfont{___}, @racketidfont{..}@racket[_k], and - @racketidfont{..}@racket[_k] for non-negative integers - @racket[_k]) or @racket[(var _id)] --- matches anything, and binds @racket[_id] to the + @racketidfont{__}@racket[_k] for non-negative integers + @racket[_k]) @margin-note{Unlike in @racket[cond] and @racket[case], + @racket[else] is not a keyword in @racket[match].} or @racket[(var _id)] + --- matches anything, and binds @racket[_id] to the matching values. If an @racket[_id] is used multiple times within a pattern, the corresponding matches must be the same according to @racket[(match-equality-test)], except that @@ -107,6 +109,11 @@ (match '(1 (x y z) 1) [(list a b a) (list a b)] [(list a b c) (list c b a)]) + (match #f + [else + (cond + [#f 'not-evaluated] + [else 'also-not-evaluated])]) ]} @item{@racketidfont{_} --- matches anything, without binding any diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/memory.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/memory.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/memory.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/memory.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -353,6 +353,9 @@ The intent of incremental mode is to significantly reduce pause times due to major collections, but incremental mode typically implies longer minor-collection times and higher memory use. + Currently, incremental mode is only really supported when + @racket[(system-type 'gc)] returns @racket['3m]; it has no + effect in other Racket variants. If the @envvar{PLT_INCREMENTAL_GC} environment variable's value starts with @litchar{0}, @litchar{n}, or @litchar{N} on diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/numbers.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/numbers.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/numbers.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/numbers.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -549,16 +549,30 @@ If @racket[w] is exact @racket[0], the result is exact @racket[1]. - If @racket[w] is @racket[0.0] or @racket[-0.0] and @racket[z] is a @tech{real number}, the + If @racket[w] is @racket[0.0] or @racket[-0.0] and @racket[z] is a @tech{real number} + other than exact @racket[1] or @racket[0], the result is @racket[1.0] (even if @racket[z] is @racket[+nan.0]). If @racket[z] is exact @racket[1], the result is exact @racket[1]. If @racket[z] is @racket[1.0] and @racket[w] is a @tech{real number}, the result is @racket[1.0] (even if @racket[w] is @racket[+nan.0]). -If @racket[z] is - exact @racket[0] and @racket[w] is negative, the - @exnraise[exn:fail:contract:divide-by-zero]. +If @racket[z] is exact @racket[0], the result is as follows: +@; +@itemlist[#:style 'compact + + @item{@racket[w] is exact @racket[0] --- result is @racket[1]} + + @item{@racket[w] is @racket[0.0] or @racket[-0.0] --- result is @racket[1.0]} + + @item{real part of @racket[w] is negative --- the @exnraise[exn:fail:contract:divide-by-zero]} + + @item{@racket[w] is nonreal with a nonpositive real part --- the @exnraise[exn:fail:contract:divide-by-zero]} + + @item{@racket[w] is @racket[+nan.0] --- result is @racket[+nan.0]} + + @item{otherwise --- result is @racket[0]} +] Further special cases when @racket[w] is a @tech{real number}: @margin-note*{These special cases correspond to @tt{pow} in C99 @cite["C99"], @@ -569,45 +583,45 @@ @item{@racket[(expt 0.0 w)]: @itemlist[#:style 'compact - @item{@racket[w] is negative --- @racket[+inf.0]} - @item{@racket[w] is positive --- @racket[0.0]}]} + @item{@racket[w] is negative --- result is @racket[+inf.0]} + @item{@racket[w] is positive --- result is @racket[0.0]}]} @item{@racket[(expt -0.0 w)]: @itemlist[#:style 'compact @item{@racket[w] is negative: @itemlist[#:style 'compact - @item{@racket[w] is an odd integer --- @racket[-inf.0]} - @item{@racket[w] otherwise rational --- @racket[+inf.0]}]} + @item{@racket[w] is an odd integer --- result is @racket[-inf.0]} + @item{@racket[w] otherwise rational --- result is @racket[+inf.0]}]} @item{@racket[w] is positive: @itemlist[#:style 'compact - @item{@racket[w] is an odd integer --- @racket[-0.0]} - @item{@racket[w] otherwise rational --- @racket[+0.0]}]}]} + @item{@racket[w] is an odd integer --- result is @racket[-0.0]} + @item{@racket[w] otherwise rational --- result is @racket[+0.0]}]}]} @item{@racket[(expt z -inf.0)] for positive @racket[z]: @itemlist[#:style 'compact - @item{@racket[z] is less than @racket[1.0] --- @racket[+inf.0]} - @item{@racket[z] is greater than @racket[1.0] --- @racket[+0.0]}]} + @item{@racket[z] is less than @racket[1.0] --- result is @racket[+inf.0]} + @item{@racket[z] is greater than @racket[1.0] --- result is @racket[+0.0]}]} @item{@racket[(expt z +inf.0)] for positive @racket[z]: @itemlist[#:style 'compact - @item{@racket[z] is less than @racket[1.0] --- @racket[+0.0]} - @item{@racket[z] is greater than @racket[1.0] --- @racket[+inf.0]}]} + @item{@racket[z] is less than @racket[1.0] --- result is @racket[+0.0]} + @item{@racket[z] is greater than @racket[1.0] --- result is @racket[+inf.0]}]} @item{@racket[(expt -inf.0 w)] for integer @racket[w]: @itemlist[#:style 'compact @item{@racket[w] is negative: @itemlist[#:style 'compact - @item{@racket[w] is odd --- @racket[-0.0]} - @item{@racket[w] is even --- @racket[+0.0]}]} + @item{@racket[w] is odd --- result is @racket[-0.0]} + @item{@racket[w] is even --- result is @racket[+0.0]}]} @item{@racket[w] is positive: @itemlist[#:style 'compact - @item{@racket[w] is odd --- @racket[-inf.0]} - @item{@racket[w] is even --- @racket[+inf.0]}]}]} + @item{@racket[w] is odd --- result is @racket[-inf.0]} + @item{@racket[w] is even --- result is @racket[+inf.0]}]}]} @item{@racket[(expt +inf.0 w)]: @itemlist[#:style 'compact - @item{@racket[w] is negative --- @racket[+0.0]} - @item{@racket[w] is positive --- @racket[+inf.0]}]} + @item{@racket[w] is negative --- result is @racket[+0.0]} + @item{@racket[w] is positive --- result is @racket[+inf.0]}]} ] @mz-examples[(expt 2 3) (expt 4 0.5) (expt +inf.0 0)]} @@ -690,7 +704,8 @@ In the one-argument case, returns the arctangent of the inexact approximation of @racket[z], except that the result is an exact - @racket[0] for an exact @racket[0] argument. + @racket[0] for @racket[z] as @racket[0], and the @exnraise[exn:fail:contract:divide-by-zero] + for @racket[z] as exact @racket[0+1i] or exact @racket[0-1i]. In the two-argument case, the result is roughly the same as @racket[ (atan (/ (exact->inexact y)) (exact->inexact x))], but the signs of @racket[y] @@ -698,11 +713,15 @@ suitable angle is returned when @racket[y] divided by @racket[x] produces @racket[+nan.0] in the case that neither @racket[y] nor @racket[x] is @racket[+nan.0]. Finally, if @racket[y] is exact - @racket[0] and @racket[x] is an exact positive number, the result is + @racket[0] and @racket[x] is a positive number, the result is exact @racket[0]. If both @racket[x] and @racket[y] are exact @racket[0], the @exnraise[exn:fail:contract:divide-by-zero]. -@mz-examples[(atan 0.5) (atan 2 1) (atan -2 -1) (atan 1+05.i) (atan +inf.0 -inf.0)]} +@mz-examples[(atan 0.5) (atan 2 1) (atan -2 -1) (atan 1+05.i) (atan +inf.0 -inf.0)] + +@history[#:changed "7.2.0.2" @elem{Changed to raise @racket[exn:fail:contract:divide-by-zero] + for @racket[0+1i] and @racket[0-1i] and to produce exact @racket[0] + for any positive @racket[x] (not just exact values) when @racket[y] is @racket[0].}]} @; ------------------------------------------------------------------------ @subsection{Complex Numbers} @@ -747,9 +766,15 @@ @defproc[(magnitude [z number?]) (and/c real? (not/c negative?))]{ Returns the magnitude of the complex number @racket[z] in polar - coordinates. - -@mz-examples[(magnitude -3) (magnitude 3.0) (magnitude 3+4i)]} + coordinates. A complex number with @racket[+inf.0] or @racket[-inf.0] + as a component has magnitude @racket[+inf.0], even if the other + component is @racket[+nan.0]. + +@mz-examples[(magnitude -3) (magnitude 3.0) (magnitude 3+4i)] + +@history[#:changed "7.2.0.2" @elem{Changed to always return @racket[+inf.0] + for a complex number with a @racket[+inf.0] + or @racket[-inf.0] component.}]} @defproc[(angle [z number?]) real?]{ Returns the angle of diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/port-procs.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/port-procs.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/port-procs.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/port-procs.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -47,16 +47,24 @@ logging. For example, the default error display handler writes to this port.} -@defproc[(file-stream-port? [port port?]) boolean?]{ -Returns @racket[#t] if the given port is a @tech{file-stream port} (see -@secref["file-ports"]), @racket[#f] otherwise.} - -@defproc[(terminal-port? [port port?]) boolean?]{ -Returns @racket[#t] if the given port is attached to an interactive -terminal, @racket[#f] otherwise.} +@defproc[(file-stream-port? [v any/c]) boolean?]{ +Returns @racket[#t] if @racket[v] is a @tech{file-stream port} (see +@secref["file-ports"]), @racket[#f] otherwise. + +@history[#:changed "7.2.0.5" @elem{Extended @racket[file-stream-port?] + to any value, instead of resticting + the domain to ports}]} + +@defproc[(terminal-port? [v any/c]) boolean?]{ +Returns @racket[#t] if @racket[v] is a port that is attached to an +interactive terminal, @racket[#f] otherwise. + +@history[#:changed "7.2.0.5" @elem{Extended @racket[terminal-port?] + to any value, instead of resticting + the domain to ports}]} @defthing[eof eof-object?]{A value (distinct from all other values) that represents an end-of-file.} -@defproc[(eof-object? [a any/c]) boolean?]{Returns @racket[#t] if +@defproc[(eof-object? [v any/c]) boolean?]{Returns @racket[#t] if @racket[v] is @racket[eof], @racket[#f] otherwise.} diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/reader-example.rkt racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/reader-example.rkt --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/reader-example.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/reader-example.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -74,8 +74,8 @@ [(integer? v) v] [(real? v) `(/ ,(numerator v) ,(denominator v))] - [(complex? v) `(make-complex ,(loop (real-part v)) - ,(loop (imag-part v)))])))] + [(complex? v) `(make-rectangular ,(loop (real-part v)) + ,(loop (imag-part v)))])))] [(list? v) `(list ,@(map loop v))] [(vector? v) `(vector ,@(map loop (vector->list v)))] [(box? v) `(box ,(loop (unbox v)))] diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/readtables.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/readtables.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/readtables.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/readtables.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -79,7 +79,8 @@ readtable?]{ Creates a new readtable that is like @racket[readtable] (which can be -@racket[#f]), except that the reader's behavior is modified for each +@racket[#f] to indicate the default readtable), +except that the reader's behavior is modified for each @racket[key] according to the given @racket[mode] and @racket[action]. The @racket[...+] for @racket[make-readtable] applies to all three of @racket[key], @racket[mode], and @racket[action]; in diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/reference.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/reference.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/reference.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/reference.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -86,7 +86,7 @@ (bib-entry #:key "C99" #:author "ISO/IEC" - #:title "ISO/IEC 9899:1999 Cor. 3:2007(E))" + #:title "ISO/IEC 9899:1999 Cor. 3:2007(E)" #:date "2007") (bib-entry #:key "Culpepper07" @@ -113,6 +113,12 @@ #:location "LISP and Functional Programming" #:date "1988") + (bib-entry #:key "Feltey18" + #:author "Daniel Feltey, Ben Greenman, Christophe Scholliers, Robert Bruce Findler, and Vincent St-Amour" + #:title "Collapsible Contracts: Fixing a Pathology of Gradual Typing" + #:location "Object-Oriented Programming, Systems, and Languages (OOPSLA)" + #:date "2018") + (bib-entry #:key "Flatt02" #:author "Matthew Flatt" #:title "Composable and Compilable Macros: You Want it When?" @@ -132,6 +138,12 @@ #:date "2002" #:location "Workshop on Scheme and Functional Programming") + (bib-entry #:key "Greenberg15" + #:author "Michael Greenberg" + #:title "Space-Efficient Manifest Contracts" + #:location "Principles of Programming Languages (POPL)" + #:date "2015") + (bib-entry #:key "Gunter95" #:author "Carl Gunter, Didier Remy, and Jon Rieke" #:title "A Generalization of Exceptions and Control in ML-like Languages" diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/runtime.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/runtime.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/runtime.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/runtime.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -26,6 +26,9 @@ @racket[64] to indicate whether Racket is running as a 32-bit program or 64-bit program. +@margin-note{See @guidesecref["virtual-machines"] for more information + about the @racket['vm] and @racket['gc] mode results.} + In @indexed-racket['vm] mode, the possible symbol results are: diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/rx.rkt racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/rx.rkt --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/rx.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/rx.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -85,11 +85,11 @@ | Modem Like Mode, but in multi mode #mode | Mode-m Like Mode, but not in multi mode #mode Class ::= \d Contains _0_-_9_ #cat 23 - | \D Contains ASCII other than those in _\d_ #cat + | \D Contains characters not in _\d_ #cat | \w Contains _a_-_z_, _A_-_Z_, _0_-_9_, ___ #cat 24 - | \W Contains ASCII other than those in _\w_ #cat + | \W Contains characters not in _\w_ #cat | \s Contains space, tab, newline, formfeed, return #cat 25 - | \S Contains ASCII other than those in _\s_ #cat + | \S Contains characters not in _\s_ #cat Posix ::= [:alpha:] Contains _a_-_z_, _A_-_Z_ #cat | [:upper:] Contains _A_-_Z_ #cat | [:lower:] Contains _a_-_z_ #cat 26 diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/sequences.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/sequences.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/sequences.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/sequences.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -1124,7 +1124,7 @@ @defproc[(stream-take [s stream?] [i exact-nonnegative-integer?]) stream?]{ - Returns a list of the first @racket[i] elements of @racket[s]. + Returns a stream of the first @racket[i] elements of @racket[s]. } @defproc[(stream-append [s stream?] ...) diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/serialization.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/serialization.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/serialization.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/serialization.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -436,8 +436,8 @@ the top level or in a module's top level (so that deserialization information can be found later). -Serialization only supports cycles involving the created structure -type when all fields are mutable (or when the cycle can be broken +Serialization supports cycles involving the created structure +type only when all fields are mutable (or when the cycle can be broken through some other mutable value). In addition to the bindings generated by @racket[struct], @@ -456,6 +456,11 @@ @racketidfont{deserialize-info:}@racket[_id]@racketidfont{-v0}. See @racket[make-deserialize-info] for more information. +Beware that the previous paragraph means that if a serializable struct +is exported via @racket[contract-out], for example, the contracts are not +checked during deserialization. Consider using @racket[struct-guard/c] +instead. + The @racket[-v0] suffix on the deserialization enables future versioning on the structure type through @racket[serializable-struct/versions]. diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/strings.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/strings.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/strings.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/strings.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -497,8 +497,9 @@ [#:repeat? repeat? any/c #f]) (listof string?)]{ -Splits the input @racket[str] on whitespaces, returning a list of -substrings of @racket[str] that are separated by @racket[sep]. The +Splits the input @racket[str] on @racket[sep], returning a list of +substrings of @racket[str] that are separated by @racket[sep], defaulting +to splitting the input on whitespaces. The input is first trimmed using @racket[sep] (see @racket[string-trim]), unless @racket[trim?] is @racket[#f]. Empty matches are handled in the same way as for @racket[regexp-split]. As a special case, if diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/stx-ops.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/stx-ops.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/stx-ops.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/stx-ops.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -282,7 +282,7 @@ @deftogether[( @defproc[(syntax-binding-set? [v any/c]) boolean?] @defproc[(syntax-binding-set) syntax-binding-set?] -@defproc[(syntax-binding-set->syntax [binding-set syntax-binding-set?] [datum any/c]) syntax-binding-set?] +@defproc[(syntax-binding-set->syntax [binding-set syntax-binding-set?] [datum any/c]) syntax?] @defproc[(syntax-binding-set-extend [binding-set syntax-binding-set?] [symbol symbol?] [phase (or/c exact-integer? #f)] @@ -300,7 +300,7 @@ A @deftech{syntax binding set} supports explicit construction of binding information for a syntax object. Start by creating an empty binding set with @racket[syntax-binding-set], add bindings with -@racket[binding-set-extend], and create a syntax object that has the +@racket[syntax-binding-set-extend], and create a syntax object that has the bindings as its @tech{lexical information} using @racket[syntax-binding-set->syntax]. diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/syntax-model.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/syntax-model.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/syntax-model.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/syntax-model.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -78,7 +78,7 @@ @tech{variable}, a @tech{syntactic form}, or a @tech{transformer}. An identifier refers to a particular binding when the reference's symbol and the identifier's symbol are the same, and when the reference's -@tech{scope set} is a subset of the binding's +@tech{scope set} is a superset of the binding's @tech{scope set}. For a given identifier, multiple bindings may have @tech{scope sets} that are subsets of the identifier's; in that case, the identifier refers to the binding whose set is a superset of all diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/syntax-util.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/syntax-util.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/syntax-util.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/syntax-util.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -164,19 +164,23 @@ identifier is not recorded as a disappeared use. } -@defproc[(record-disappeared-uses [id (or/c identifier? (listof identifier?))]) +@defproc[(record-disappeared-uses [id (or/c identifier? (listof identifier?))] + [intro? boolean? (syntax-transforming?)]) void?]{ -Add @racket[id] to @racket[(current-recorded-disappeared-uses)] after calling -@racket[syntax-local-introduce] on the identifier. If @racket[id] is a list, -perform the same operation on all the identifiers. +Add @racket[id] to @racket[(current-recorded-disappeared-uses)]. If +@racket[id] is a list, perform the same operation on all the +identifiers. If @racket[intro?] is true, then +@racket[syntax-local-introduce] is first called on the identifiers. If not used within the extent of a @racket[with-disappeared-uses] form or similar, has no effect. @history[#:changed "6.5.0.7" @elem{Added the option to pass a single identifier instead of - requiring a list.}] + requiring a list.} + #:changed "7.2.0.11" + @elem{Added the @racket[intro?] argument.}] } diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/unsafe.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/unsafe.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/reference/unsafe.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/reference/unsafe.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -553,6 +553,17 @@ @history[#:added "6.4.0.6" #:changed "7.0.0.10" @elem{Added the optional @racket[bad-index-v] argument.}]} +@defproc[(unsafe-make-srcloc [source any/c] + [line (or/c exact-positive-integer? #f)] + [column (or/c exact-nonnegative-integer? #f)] + [position (or/c exact-positive-integer? #f)] + [span (or/c exact-nonnegative-integer? #f)]) + srcloc?]{ + +Unsafe version of @racket[srcloc]. + +@history[#:added "7.2.0.10"]} + @; ------------------------------------------------------------------------ @section[#:tag "unsafeextfl"]{Unsafe Extflonum Operations} diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/style/style.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/style/style.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/style/style.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/style/style.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -16,7 +16,7 @@ help us, the developers, and our users, who use the open source code in our repository as an implicit guide to Racket programming. -To help manage the growth our code and showcase good Racket style, we need +To help manage the growth of our code and showcase good Racket style, we need guidelines that shape the contributions to the code base. These guidelines should achieve some level of consistency across the different portions of the code base so that everyone who opens files can easily find their way diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/style/testing.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/style/testing.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/style/testing.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/style/testing.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -16,7 +16,7 @@ Run the test suites before you commit. To facilitate testing, we urge you to add a @tt{TESTME.txt} file to your collections. Ideally, you may also wish to have a file in this directory that runs the basic tests. See the - @hyperlink["https://github.com/racket/racket/tree/master/collects/2htdp/"]{2htdp}, + @hyperlink["https://github.com/racket/htdp/tree/master/htdp-test/2htdp"]{2htdp}, which is one of the collections with its own testing style. The file should describe where the tests are located, how to run these tests, and what to look for in terms of successes and failures. These files are necessary diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/style/unit.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/style/unit.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/scribblings/style/unit.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/scribblings/style/unit.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -290,7 +290,7 @@ ;; ;; (define-strategy (s board tiles available score) ...) ;; defines a function from an instance of player to a - ;; placement. The four identifier denote the state of + ;; placement. The four identifiers denote the state of ;; the board, the player's hand, the places where a ;; tile can be placed, and the player's current score. define-strategy) @@ -323,8 +323,9 @@ Finally pick the same name for all function/method arguments in a module that refer to the same kind of data---regardless of whether the module implements a common data structure. For example, in - @filepath{collects/setup/scribble}, all functions use @racket[latex-dest] - to refer to the same kind of data, even those that are not exported. + @hyperlink["https://github.com/racket/racket/blob/master/pkgs/racket-index/setup/scribble.rkt"]{@filepath{pkgs/racket-index/setup/scribble.rkt}}, + all functions use @racket[latex-dest] to refer to the same kind of data, + even those that are not exported. @subsection{Sections and Sub-modules} diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/syntax/scribblings/contract.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/syntax/scribblings/contract.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/syntax/scribblings/contract.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/syntax/scribblings/contract.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -14,14 +14,15 @@ @defproc[(wrap-expr/c [contract-expr syntax?] [expr syntax?] + [#:arg? arg? any/c #t] [#:positive pos-blame (or/c syntax? string? module-path-index? 'from-macro 'use-site 'unknown) - 'use-site] + 'from-macro] [#:negative neg-blame (or/c syntax? string? module-path-index? 'from-macro 'use-site 'unknown) - 'from-macro] + 'use-site] [#:name expr-name (or/c identifier? symbol? string? #f) #f] [#:macro macro-name @@ -68,7 +69,9 @@ (app (lambda (x) 'pear) 5) ] -@history[#:added "6.3"]{} -} +@history[#:added "6.3" #:changed "7.2.0.3" @elem{Added the +@racket[#:arg?] keyword argument and changed the default values and +interpretation of the @racket[#:positive] and @racket[#:negative] +arguments.}]} @close-eval[the-eval] diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/syntax/scribblings/parse/ex-exprc.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/ex-exprc.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/syntax/scribblings/parse/ex-exprc.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/ex-exprc.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -40,4 +40,25 @@ pattern variables are bound; it only computes an attribute that represents the checked expression. +The previous example shows a macro applying a contract on an argument, +but a macro can also apply a contract to an expression that it +produces. In that case, it should use @racket[#:arg? #f] to indicate +that the macro, not the calling context, is responsible for expression +produced. + +@interaction[#:eval the-eval +(code:comment "BUG: rationals not closed under inversion") +(define-syntax (invert stx) + (syntax-parse stx + [(_ e) + #:declare e (expr/c #'rational?) + #:with result #'(/ 1 e.c) + #:declare result (expr/c #'rational? #:arg? #f) + #'result.c])) + +(invert 4) +(invert 'abc) +(invert 0.0) +] + @(close-eval the-eval) diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/syntax/scribblings/parse/experimental.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/experimental.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/syntax/scribblings/parse/experimental.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/experimental.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -207,7 +207,8 @@ are prefixed with the name given to @racket[~eh-var]. Unlike syntax classes, ellipsis-head alternative sets must be defined -before they are referenced. +before they are referenced, and they do not delimit cuts (use +@racket[~delimit-cut] instead). } @racketgrammar*[#:literals (~eh-var) diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/syntax/scribblings/parse/lib.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/lib.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/syntax/scribblings/parse/lib.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/lib.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -37,7 +37,9 @@ @defstxclass[integer] @defstxclass[exact-integer] @defstxclass[exact-nonnegative-integer] -@defstxclass[exact-positive-integer])]{ +@defstxclass[exact-positive-integer] +@defstxclass[regexp] +@defstxclass[byte-regexp])]{ Match syntax satisfying the corresponding predicates. } @@ -59,6 +61,7 @@ @defstxclass[id]{ Alias for @racket[identifier]. } @defstxclass[nat]{ Alias for @racket[exact-nonnegative-integer]. } @defstxclass[str]{ Alias for @racket[string]. } +@defstxclass[character]{ Alias for @racket[char]. } @defstxclass[(static [predicate (-> any/c any/c)] [description (or/c string? #f)])]{ @@ -84,28 +87,36 @@ state under the key @racket['literals].}]} @defstxclass[(expr/c [contract-expr syntax?] + [#:arg? arg? any/c #t] [#:positive pos-blame (or/c syntax? string? module-path-index? 'from-macro 'use-site 'unknown) - 'use-site] + 'from-macro] [#:negative neg-blame (or/c syntax? string? module-path-index? 'from-macro 'use-site 'unknown) - 'from-macro] + 'use-site] [#:name expr-name (or/c identifier? string? symbol?) #f] [#:macro macro-name (or/c identifier? string? symbol?) #f] - [#:context ctx (or/c syntax? #f) #, @elem{determined automatically}])]{ + [#:context context (or/c syntax? #f) #, @elem{determined automatically}])]{ Accepts an expression (@racket[expr]) and computes an attribute @racket[c] that represents the expression wrapped with the contract -represented by @racket[contract-expr]. - -The contract's positive blame represents the obligations of the -expression being wrapped. The negative blame represents the -obligations of the macro imposing the contract---the ultimate user -of @racket[expr/c]. By default, the positive blame is taken as -the module currently being expanded, and the negative blame is -inferred from the definition site of the macro (itself inferred from -the @racket[context] argument), but both blame locations can be -overridden. +represented by @racket[contract-expr]. Note that +@racket[contract-expr] is potentially evaluated each time the code +generated by the macro is run; for the best performance, +@racket[contract-expr] should be a variable reference. + +The positive blame represents the obligations of the macro imposing +the contract---the ultimate user of @racket[expr/c]. The contract's +negative blame represents the obligations of the expression being +wrapped. By default, the positive blame is inferred from the +definition site of the macro (itself inferred from the +@racket[context] argument), and the negative blame is taken as the +module currently being expanded, but both blame locations can be +overridden. When @racket[arg?] is @racket[#t], the term being matched +is interpreted as an argument (that is, coming from the negative +party); when @racket[arg?] is @racket[#f], the term being matched is +interpreted as a result of the macro (that is, coming from the +positive party). The @racket[pos-blame] and @racket[neg-blame] arguments are turned into blame locations as follows: @@ -151,7 +162,10 @@ @racket[c] attribute. The @racket[expr/c] syntax class does not change how pattern variables are bound; it only computes an attribute that represents the checked expression. -} + +@history[#:changed "7.2.0.3" @elem{Added the @racket[#:arg?] keyword +argument and changed the default values and interpretation of the +@racket[#:positive] and @racket[#:negative] arguments.}]} @section{Literal Sets} diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/syntax/scribblings/parse/parse-common.rkt racket-7.3+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/parse-common.rkt --- racket-7.2+ppa2/share/pkgs/racket-doc/syntax/scribblings/parse/parse-common.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/parse-common.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -54,7 +54,8 @@ syntax/parse/experimental/reflect syntax/parse/experimental/specialize syntax/parse/experimental/template - syntax/parse/experimental/eh)]) + syntax/parse/experimental/eh + syntax/transformer)]) `((for-syntax racket/base ,@mods) ,@mods))))))) (when short? (the-eval '(error-print-source-location #f))) @@ -120,6 +121,7 @@ syntax/parse/experimental/specialize syntax/parse/experimental/template syntax/parse/experimental/eh + syntax/transformer "parse-dummy-bindings.rkt")) (provide (for-label (all-from-out racket/base) (all-from-out racket/contract) @@ -132,4 +134,5 @@ (all-from-out syntax/parse/experimental/specialize) (all-from-out syntax/parse/experimental/template) (all-from-out syntax/parse/experimental/eh) + (all-from-out syntax/transformer) (all-from-out "parse-dummy-bindings.rkt"))) diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/syntax/scribblings/parse/stxclasses.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/stxclasses.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/syntax/scribblings/parse/stxclasses.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/syntax/scribblings/parse/stxclasses.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -188,6 +188,42 @@ the pattern variables. } +@defthing[prop:syntax-class (struct-type-property/c (or/c identifier? + (-> any/c identifier?)))]{ + +A @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{structure type property} to identify +structure types that act as an alias for a @tech{syntax class} or @tech{splicing syntax class}. The +property value must be an identifier or a procedure of one argument. + +When a @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{transformer} is bound to an +instance of a struct with this property, then it may be used as a @tech{syntax class} or +@tech{splicing syntax class} in the same way as the bindings created by @racket[define-syntax-class] +or @racket[define-splicing-syntax-class]. If the value of the property is an identifier, then it +should be bound to a @tech{syntax class} or @tech{splicing syntax class}, and the binding will be +treated as an alias for the referenced syntax class. If the value of the property is a procedure, then +it will be applied to the value with the @racket[prop:syntax-class] property to obtain an identifier, +which will then be used as in the former case. + +@examples[#:eval the-eval +(begin-for-syntax + (struct expr-and-stxclass (expr-id stxclass-id) + #:property prop:procedure + (lambda (this stx) ((set!-transformer-procedure + (make-variable-like-transformer + (expr-and-stxclass-expr-id this))) + stx)) + #:property prop:syntax-class + (lambda (this) (expr-and-stxclass-stxclass-id this)))) +(define-syntax is-id? (expr-and-stxclass #'identifier? #'id)) +(is-id? #'x) +(syntax-parse #'x + [x:is-id? #t] + [_ #f]) +] + +@history[#:added "7.2.0.4"] +} + @;{--------} @section{Pattern Directives} diff -Nru racket-7.2+ppa2/share/pkgs/racket-doc/syntax/scribblings/transformer.scrbl racket-7.3+ppa1/share/pkgs/racket-doc/syntax/scribblings/transformer.scrbl --- racket-7.2+ppa2/share/pkgs/racket-doc/syntax/scribblings/transformer.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-doc/syntax/scribblings/transformer.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -8,20 +8,24 @@ @defmodule[syntax/transformer] -@defproc[(make-variable-like-transformer [reference-stx syntax?] - [setter-stx (or/c syntax? #f) #f]) - set!-transformer?]{ +@defproc[(make-variable-like-transformer + [reference-stx (or/c syntax? (-> identifier? syntax?))] + [setter-stx (or/c syntax? (-> syntax? syntax?) #f) #f]) + (and/c set!-transformer? (-> syntax? syntax?))]{ Creates a transformer that replaces references to the macro identifier with @racket[reference-stx]. Uses of the macro in operator position are interpreted as an application with @racket[reference-stx] as the -function and the arguments as given. +function and the arguments as given. If the @racket[reference-stx] is +a procedure, it is applied to the macro identifier. If the macro identifier is used as the target of a @racket[set!] form, then the @racket[set!] form expands into the application of @racket[setter-stx] to the @racket[set!] expression's right-hand side, if @racket[setter-stx] is syntax; otherwise, the identifier is -considered immutable and a syntax error is raised. +considered immutable and a syntax error is raised. If +@racket[setter-stx] is a procedure, it is applied to the entire +@racket[set!] expression. @examples[#:eval the-eval (define the-box (box add1)) diff -Nru racket-7.2+ppa2/share/pkgs/racket-index/info.rkt racket-7.3+ppa1/share/pkgs/racket-index/info.rkt --- racket-7.2+ppa2/share/pkgs/racket-index/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-index/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/racket-lib/info.rkt racket-7.3+ppa1/share/pkgs/racket-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/racket-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racket-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.3"))) (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-7.2+ppa2/share/pkgs/racklog/info.rkt racket-7.3+ppa1/share/pkgs/racklog/info.rkt --- racket-7.2+ppa2/share/pkgs/racklog/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/racklog/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/rackunit/info.rkt racket-7.3+ppa1/share/pkgs/rackunit/info.rkt --- racket-7.2+ppa2/share/pkgs/rackunit/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/rackunit/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/rackunit-doc/info.rkt racket-7.3+ppa1/share/pkgs/rackunit-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/rackunit-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/rackunit-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/rackunit-gui/info.rkt racket-7.3+ppa1/share/pkgs/rackunit-gui/info.rkt --- racket-7.2+ppa2/share/pkgs/rackunit-gui/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/rackunit-gui/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/rackunit-lib/info.rkt racket-7.3+ppa1/share/pkgs/rackunit-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/rackunit-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/rackunit-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.10"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.3"))) (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.10"))) diff -Nru racket-7.2+ppa2/share/pkgs/rackunit-plugin-lib/info.rkt racket-7.3+ppa1/share/pkgs/rackunit-plugin-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/rackunit-plugin-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/rackunit-plugin-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/rackunit-typed/info.rkt racket-7.3+ppa1/share/pkgs/rackunit-typed/info.rkt --- racket-7.2+ppa2/share/pkgs/rackunit-typed/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/rackunit-typed/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/readline/info.rkt racket-7.3+ppa1/share/pkgs/readline/info.rkt --- racket-7.2+ppa2/share/pkgs/readline/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/readline/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/readline-doc/info.rkt racket-7.3+ppa1/share/pkgs/readline-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/readline-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/readline-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/readline-lib/info.rkt racket-7.3+ppa1/share/pkgs/readline-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/readline-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/readline-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (define collection (quote multi)) (define deps (quote (("base" #:version "6.90")))) (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.3"))) (define collection (quote multi)) (define deps (quote (("base" #:version "6.90")))) (define pkg-desc "implementation (no documentation) part of \"readline\"") (define pkg-authors (quote (mflatt))) (define version "1.1"))) diff -Nru racket-7.2+ppa2/share/pkgs/realm/info.rkt racket-7.3+ppa1/share/pkgs/realm/info.rkt --- racket-7.2+ppa2/share/pkgs/realm/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/realm/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/redex/info.rkt racket-7.3+ppa1/share/pkgs/redex/info.rkt --- racket-7.2+ppa2/share/pkgs/redex/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/redex/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/redex-benchmark/info.rkt racket-7.3+ppa1/share/pkgs/redex-benchmark/info.rkt --- racket-7.2+ppa2/share/pkgs/redex-benchmark/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/redex-benchmark/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/redex-doc/info.rkt racket-7.3+ppa1/share/pkgs/redex-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/redex-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/redex-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/redex-doc/redex/scribblings/ref/other-relations.scrbl racket-7.3+ppa1/share/pkgs/redex-doc/redex/scribblings/ref/other-relations.scrbl --- racket-7.2+ppa2/share/pkgs/redex-doc/redex/scribblings/ref/other-relations.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/redex-doc/redex/scribblings/ref/other-relations.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -243,8 +243,8 @@ ([mode-spec (code:line #:mode (form-id pos-use ...))] [contract-spec (code:line) (code:line #:contract (form-id @#,ttpattern-sequence ...))] - [invariant-spec (code:line #:inv @#,tttterm) - (code:line)] + [invariant-spec (code:line) + (code:line #:inv @#,tttterm)] [pos-use I O] [rule [premise @@ -289,8 +289,8 @@ these positions match the provided patterns, raising an exception recognized by @racket[exn:fail:redex?] if not. The term in the optional @racket[invariant-spec] is evaluated after the output positions have been computed and the contract has matched -successfully, with variables from the contract bound; a result of @racket[#f] is -considered to be a contract violation and an exception is raised. +successfully, with variables (that have underscores) from the contract bound; +a result of @racket[#f] is considered to be a contract violation and an exception is raised. For example, the following defines addition on natural numbers: @examples[#:label #f #:eval redex-eval @@ -450,6 +450,10 @@ "examples" "define-judgment-form")] replacing @bold{«filename.rkt»} with one of the names listed above. + +Note that @racket[current-traced-metafunctions] also traces judgment forms and is +helpful when debugging. + } @defform[(define-extended-judgment-form language judgment-form-id @@ -565,17 +569,36 @@ @defparam[current-traced-metafunctions traced-metafunctions (or/c 'all (listof symbol?))]{ -Controls which metafunctions are currently being traced. If it is +Controls which metafunctions and judgment forms are currently being traced. If it is @racket['all], all of them are. Otherwise, the elements of the list -name the metafunctions to trace. +name the metafunctions and judgments to trace. The tracing looks just like the tracing done by the @racketmodname[racket/trace] library, except that the first column printed by each traced call indicate if this call to the metafunction is cached. Specifically, a @tt{c} is printed in the first column if the result is just returned from the cache and a -space is printed if the metafunction call is actually performed. +space is printed if the metafunction or judgment call is actually performed. Defaults to @racket['()]. + +@examples[ + #:eval redex-eval + (define-judgment-form nats + #:mode (odd I) + #:contract (odd n) + + [-------- "oddsz" + (odd (s z))] + + [(odd n) + ---------------- "odd2" + (odd (s (s n)))]) + (parameterize ([current-traced-metafunctions '(odd)]) + (judgment-holds (odd (s (s (s z)))))) + + (parameterize ([current-traced-metafunctions '(odd)]) + (judgment-holds (odd (s (s (s (s (s z))))))))] + } @(close-eval redex-eval) diff -Nru racket-7.2+ppa2/share/pkgs/redex-doc/redex/scribblings/ref/typesetting.scrbl racket-7.3+ppa1/share/pkgs/redex-doc/redex/scribblings/ref/typesetting.scrbl --- racket-7.2+ppa2/share/pkgs/redex-doc/redex/scribblings/ref/typesetting.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/redex-doc/redex/scribblings/ref/typesetting.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -18,7 +18,8 @@ #f (list (make-paragraph (list (racketidfont (make-element #f (list (symbol->string 'a0)))) - (make-element #f (list " " (hspace 1) " " (racketidfont (symbol->string 'a)))) + (make-element #f (list " " (hspace 1) " " + (racketidfont (make-element #f (list (symbol->string 'a)))))) ...))))) @(define redex-eval (make-base-eval '(require redex/reduction-semantics redex/pict racket/port))) diff -Nru racket-7.2+ppa2/share/pkgs/redex-examples/info.rkt racket-7.3+ppa1/share/pkgs/redex-examples/info.rkt --- racket-7.2+ppa2/share/pkgs/redex-examples/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/redex-examples/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/redex-gui-lib/info.rkt racket-7.3+ppa1/share/pkgs/redex-gui-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/redex-gui-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/redex-gui-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/redex-lib/info.rkt racket-7.3+ppa1/share/pkgs/redex-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/redex-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/redex-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.14"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.3"))) (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.14"))) diff -Nru racket-7.2+ppa2/share/pkgs/redex-lib/redex/HISTORY.txt racket-7.3+ppa1/share/pkgs/redex-lib/redex/HISTORY.txt --- racket-7.2+ppa2/share/pkgs/redex-lib/redex/HISTORY.txt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/redex-lib/redex/HISTORY.txt 2019-05-16 01:29:07.000000000 +0000 @@ -1,3 +1,7 @@ +v7.3 + + * misc minor bug fixes + v7.2 * added derivation->pict diff -Nru racket-7.2+ppa2/share/pkgs/redex-lib/redex/private/judgment-form.rkt racket-7.3+ppa1/share/pkgs/redex-lib/redex/private/judgment-form.rkt --- racket-7.2+ppa2/share/pkgs/redex-lib/redex/private/judgment-form.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/redex-lib/redex/private/judgment-form.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1412,7 +1412,7 @@ (unless (match-pattern contracts io-term) (redex-error form-name (string-append - "judgment values do not match its contract;\n" + "judgment values do not match its contract (or invariant);\n" " contract: ~s\n" " values: ~s") (cons form-name orig-ctcs) (cons form-name io-term)))]))) @@ -1457,6 +1457,13 @@ [(prem . remaining) (cons #'prem (drop-ellipses #'remaining))])) (define (fold-clause pat-pos tmpl-pos acc-init clause) + (define (raise-length-error name source expected actual) + (raise-syntax-error syn-err-name + (format "~a expected ~a part(s), but got ~a" + (syntax-e name) + expected + (length (syntax->list actual))) + source)) (syntax-case clause () [(conc . prems) (let-values ([(conc-in conc-out) (split-body #'conc)]) @@ -1470,10 +1477,16 @@ (begin (tmpl-pos #'tmpl acc) (pat-pos #'pat acc))] + [(-where e ...) + (where-keyword? #'-where) + (raise-length-error #'-where prem 2 #'(e ...))] [(-side-condition tmpl) (side-condition-keyword? #'-side-condition) (begin (tmpl-pos #'tmpl acc) acc)] + [(-side-condition e ...) + (side-condition-keyword? #'-side-condition) + (raise-length-error #'-side-condition prem 1 #'(e ...))] [(form-name . _) (if (judgment-form-id? #'form-name) (let-values ([(prem-in prem-out) (split-body prem)]) @@ -1599,10 +1612,6 @@ [mode (let ([m (syntax->datum #'mode-arg)]) (and m (cdr m)))]) (unless (jf-is-relation? #'judgment-form-name) (mode-check (cdr (syntax->datum #'mode-arg)) clauses nts syn-err-name stx)) - (define maybe-wrap-contract (if (syntax-e #'invt) - (λ (ctc-stx) - #`(side-condition #,ctc-stx (term invt))) - values)) (define-values (i-ctc-syncheck-expr i-ctc contract-original-expr) (syntax-case #'ctcs () [#f (values #'(void) #f #f)] diff -Nru racket-7.2+ppa2/share/pkgs/redex-lib/redex/private/term-fn.rkt racket-7.3+ppa1/share/pkgs/redex-lib/redex/private/term-fn.rkt --- racket-7.2+ppa2/share/pkgs/redex-lib/redex/private/term-fn.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/redex-lib/redex/private/term-fn.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -33,7 +33,8 @@ (make-struct-type 'term-fn #f 1 0)) (define term-fn-get-id (make-struct-field-accessor term-fn-get 0)) -(define-struct term-id (id depth prev-id)) +(define-struct term-id (id depth prev-id transformer) + #:property prop:procedure (struct-field-index transformer)) (define (transformer-predicate p? stx) (and (identifier? stx) diff -Nru racket-7.2+ppa2/share/pkgs/redex-lib/redex/private/term.rkt racket-7.3+ppa1/share/pkgs/redex-lib/redex/private/term.rkt --- racket-7.2+ppa2/share/pkgs/redex-lib/redex/private/term.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/redex-lib/redex/private/term.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -505,6 +505,19 @@ (define-syntax id (make-term-fn #'id2)))))])) +(begin-for-syntax + (define (forward-id id-to-rewrite-to) + (λ (stx) + (syntax-case stx (set!) + [(id . args) + (with-syntax ([app (datum->syntax #'here '#%app)]) + #`(app #,id-to-rewrite-to . args))] + [(set! id e) + #`(set! #,id-to-rewrite-to e)] + [x + (identifier? #'x) + id-to-rewrite-to])))) + (define-syntax (term-let/error-name stx) (syntax-case stx () [(_ error-name ([x1 rhs1] [x rhs] ...) body1 body2 ...) @@ -568,7 +581,9 @@ (syntax/loc stx (datum-case rhs1 () [new-x1 - (let-syntax ([orig-names (make-term-id #'new-names depths #'orig-names)] ...) + (let-syntax ([orig-names (make-term-id #'new-names depths #'orig-names + (forward-id #'orig-names))] + ...) (term-let/error-name error-name ((x rhs) ...) body1 body2 ...))] [_ no-match])))))] [(_ error-name () body1 body2 ...) diff -Nru racket-7.2+ppa2/share/pkgs/redex-pict-lib/info.rkt racket-7.3+ppa1/share/pkgs/redex-pict-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/redex-pict-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/redex-pict-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.8"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.3"))) (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.8"))) diff -Nru racket-7.2+ppa2/share/pkgs/sandbox-lib/info.rkt racket-7.3+ppa1/share/pkgs/sandbox-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/sandbox-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/sandbox-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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))) (define version "1.1"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.3"))) (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))) (define version "1.1"))) diff -Nru racket-7.2+ppa2/share/pkgs/sasl/info.rkt racket-7.3+ppa1/share/pkgs/sasl/info.rkt --- racket-7.2+ppa2/share/pkgs/sasl/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/sasl/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.3"))) (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-7.2+ppa2/share/pkgs/sasl-doc/info.rkt racket-7.3+ppa1/share/pkgs/sasl-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/sasl-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/sasl-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.3"))) (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-7.2+ppa2/share/pkgs/sasl-lib/info.rkt racket-7.3+ppa1/share/pkgs/sasl-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/sasl-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/sasl-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (define version "1.0") (define collection "sasl") (define deps (quote (("base" #:version "6.10")))) (define pkg-authors (quote (ryanc))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.3"))) (define version "1.0") (define collection "sasl") (define deps (quote (("base" #:version "6.10")))) (define pkg-authors (quote (ryanc))))) diff -Nru racket-7.2+ppa2/share/pkgs/scheme-lib/info.rkt racket-7.3+ppa1/share/pkgs/scheme-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/scheme-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/scheme-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (define collection (quote multi)) (define deps (quote ("base"))) (define pkg-desc "Legacy (Scheme) libraries") (define pkg-authors (quote (mflatt))))) diff -Nru racket-7.2+ppa2/share/pkgs/schemeunit/info.rkt racket-7.3+ppa1/share/pkgs/schemeunit/info.rkt --- racket-7.2+ppa2/share/pkgs/schemeunit/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/schemeunit/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/scribble/info.rkt racket-7.3+ppa1/share/pkgs/scribble/info.rkt --- racket-7.2+ppa2/share/pkgs/scribble/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/scribble/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/scribble-doc/info.rkt racket-7.3+ppa1/share/pkgs/scribble-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/scribble-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/scribble-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/scribble-doc/scribblings/scribble/config.scrbl racket-7.3+ppa1/share/pkgs/scribble-doc/scribblings/scribble/config.scrbl --- racket-7.2+ppa2/share/pkgs/scribble-doc/scribblings/scribble/config.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/scribble-doc/scribblings/scribble/config.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -75,7 +75,7 @@ list. To map a style name to a Latex macro or environment, add a @racket[tex-addition] structure instance. A @racket[css-addition] or @racket[tex-addition] is normally associated with the style whose name -is implemented by the adition, but it can also be added to the style +is implemented by the addition, but it can also be added to the style for an enclosing part. Scribble includes a number of predefined styles that are used by the @@ -369,6 +369,7 @@ add space before and after suitable for code.}] [@css{SCentered} @elem{For a @racket[nested-flow] created by @racket[centered]: horizontally centered.}] + [@css{SVerbatim} @elem{For a @racket[table] created by @racket[verbatim]: disables line breaks.}] [@spacer @spacer] @@ -630,7 +631,10 @@ with the @racket['code-inset] style name.} @item{@ltxe{SVInsetFlow} environment --- for a @racket[nested-flow] - with the @racket['vertical-inset] style name.} + with the @racket['vertical-inset] style name.} + + @item{@ltxe{SVerbatim} environment --- for a @racket[table] created + by @racket[verbatim].} @item{@ltxd[1]{SCodeBox}, @ltxd[1]{SVInsetBox} --- for a @racket[nested-flow] with the @racket['code-inset] or diff -Nru racket-7.2+ppa2/share/pkgs/scribble-doc/scribblings/scribble/manual.scrbl racket-7.3+ppa1/share/pkgs/scribble-doc/scribblings/scribble/manual.scrbl --- racket-7.2+ppa2/share/pkgs/scribble-doc/scribblings/scribble/manual.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/scribble-doc/scribblings/scribble/manual.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -184,13 +184,14 @@ [#:keep-lang-line? keep? any/c #t] [#:line-numbers line-numbers (or/c #f exact-nonnegative-integer?) #f] [#:line-number-sep line-number-sep exact-nonnegative-integer? 1] - [#:block? block? #t] + [#:block? return-block? any/c #t] [strs string?] ...) - block?]{ + (if return-block? block? element?)]{ A function-based version of @racket[codeblock], allowing you to compute the @racket[strs] arguments. Unlike @racket[codeblock], the default @racket[context] argument (@racket[#f]) implies that - the context is untouched. The other arguments are treated the same way. + the context is untouched and the @racket[return-block?] argument determines the result + structure. The other arguments are treated the same way as @racket[codeblock]. } @; ---------------------------------------- diff -Nru racket-7.2+ppa2/share/pkgs/scribble-doc/scribblings/scribble/renderer.scrbl racket-7.3+ppa1/share/pkgs/scribble-doc/scribblings/scribble/renderer.scrbl --- racket-7.2+ppa2/share/pkgs/scribble-doc/scribblings/scribble/renderer.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/scribble-doc/scribblings/scribble/renderer.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -170,9 +170,9 @@ is a result from the @method[render<%> collect] method.} @defmethod[(render [srcs (listof part?)] - [dests (listof path-string?)] + [dests (listof (or/c path-string? #f))] [ri resolve-info?]) - void?]{ + list?]{ Produces the final output. The @racket[ri] argument is a result from the @method[render<%> render] method. @@ -182,7 +182,11 @@ If the @racket[dests] are relative, they're relative to the current directory; normally, they should indicates a path within the @racket[_dest-dir] supplied on initialization of the @racket[render%] -object.} +object. + +If an element of @racket[dests] is @racket[#f], then the corresponding +position of the result list contains a string for rendered document. +Some renderers require that @racket[dest] contains all path strings.} @defmethod[(serialize-info [ri resolve-info?]) @@ -299,7 +303,284 @@ formats listed in @racket[image-preferences]. @history[#:changed "1.4" @elem{Added the @racket[image-preferences] - initialization argument.}]}} + initialization argument.}]} + +@defmethod[(traverse [parts (listof part?)] + [dests (listof path-string?)]) + (and/c hash? immutable?)] +@defmethod[(start-traverse [parts (listof part?)] + [dests (listof path-string?)] + [fp (and/c hash? immutable?)]) + (and/c hash? immutable?)] +@defmethod[(traverse-part [p part?] + [fp (and/c hash? immutable?)]) + (and/c hash? immutable?)] +@defmethod[(traverse-flow [bs (listof block?)] + [fp (and/c hash? immutable?)]) + (and/c hash? immutable?)] +@defmethod[(traverse-block [b block?] + [fp (and/c hash? immutable?)]) + (and/c hash? immutable?)] +@defmethod[(traverse-nested-flow [nf nested-flow?] + [fp (and/c hash? immutable?)]) + (and/c hash? immutable?)] +@defmethod[(traverse-table [t table?] + [fp (and/c hash? immutable?)]) + (and/c hash? immutable?)] +@defmethod[(traverse-itemization [i itemization?] + [fp (and/c hash? immutable?)]) + (and/c hash? immutable?)] +@defmethod[(traverse-compound-paragraph [cp compound-paragraph?] + [fp (and/c hash? immutable?)]) + (and/c hash? immutable?)] +@defmethod[(traverse-paragraph [p paragraph?] + [fp (and/c hash? immutable?)]) + (and/c hash? immutable?)] +@defmethod[(traverse-content [c content?] + [fp (and/c hash? immutable?)]) + (and/c hash? immutable?)] +@defmethod[(traverse-target-element [e target-element?] + [fp (and/c hash? immutable?)]) + (and/c hash? immutable?)] +@defmethod[(traverse-index-element [e index-element?] + [fp (and/c hash? immutable?)]) + (and/c hash? immutable?)]{ + +These methods implement the @tech{traverse pass} of document rendering. +Except for the entry point @method[render% traverse] as described by +as described at @xmethod[render<%> traverse], these methods +generally would not be called to render a document, but instead +provide natural points to interpose on the default implementation. + +A renderer for a specific format is relatively unlikely to override +any of these methods. Each method accepts the information accumulated +so far and returns augmented information as a result.} + + +@defmethod[(collect [parts (listof part?)] + [dests (listof path-string?)] + [fp (and/c hash? immutable?)] + [demand (tag? collect-info? . -> . any/c) (lambda (_tag _ci) #f)]) + collect-info?] +@defmethod[(start-collect [parts (listof part?)] + [dests (listof path-string?)] + [ci collect-info?]) + void?] +@defmethod[(collect-part [p part?] + [parent (or/c #f part?)] + [ci collect-info?] + [number (listof part-number-item?)] + [init-sub-number part-number-item?] + [init-sub-numberers (listof numberer?)]) + (values part-number-item? numberer?)] +@defmethod[(collect-part-tags [p part?] + [ci collect-info?] + [number (listof part-number-item?)]) + void?] +@defmethod[(collect-flow [bs (listof block?)] + [ci collect-info?]) + void?] +@defmethod[(collect-block [b block?] + [ci collect-info?]) + void?] +@defmethod[(collect-nested-flow [nf nested-flow?] + [ci collect-info?]) + void?] +@defmethod[(collect-table [t table?] + [ci collect-info?]) + void?] +@defmethod[(collect-itemization [i itemization?] + [ci collect-info?]) + void?] +@defmethod[(collect-compound-paragraph [cp compound-paragraph?] + [ci collect-info?]) + void?] +@defmethod[(collect-paragraph [p paragraph?] + [ci collect-info?]) + void?] +@defmethod[(collect-content [c content?] + [ci collect-info?]) + void?] +@defmethod[(collect-target-element [e target-element?] + [ci collect-info?]) + void?] +@defmethod[(collect-index-element [e index-element?] + [ci collect-info?]) + void?]{ + +These methods implement the @tech{collect pass} of document rendering. +Except for the entry point @method[render% collect] as described at +@xmethod[render<%> collect], these methods generally would not be +called to render a document, but instead provide natural points to +interpose on the default implementation. + +A renderer for a specific format is most likely to override +@method[render% collect-part-tags], @method[render% +collect-target-element], and perhaps @method[render% start-collect] to +set up and record cross-reference information in a way that is +suitable for the target format.} + +@defmethod[(resolve [parts (listof part?)] + [dests (listof path-string?)] + [ci collect-info?]) + resolve-info?] +@defmethod[(start-resolve [parts (listof part?)] + [dests (listof path-string?)] + [ri resolve-info?]) + void?] +@defmethod[(resolve-part [p part?] + [ri resolve-info?]) + void?] +@defmethod[(resolve-flow [bs (listof block?)] + [enclosing-p part?] + [ri resolve-info?]) + void?] +@defmethod[(resolve-block [b block?] + [enclosing-p part?] + [ri resolve-info?]) + void?] +@defmethod[(resolve-nested-flow [nf nested-flow?] + [enclosing-p part?] + [ri resolve-info?]) + void?] +@defmethod[(resolve-table [t table?] + [enclosing-p part?] + [ri resolve-info?]) + void?] +@defmethod[(resolve-itemization [i itemization?] + [enclosing-p part?] + [ri resolve-info?]) + void?] +@defmethod[(resolve-compound-paragraph [cp compound-paragraph?] + [enclosing-p part?] + [ri resolve-info?]) + void?] +@defmethod[(resolve-paragraph [p paragraph?] + [enclosing-p part?] + [ri resolve-info?]) + void?] +@defmethod[(resolve-content [c content?] + [enclosing-p part?] + [ri resolve-info?]) + void?]{ + +These methods implement the @tech{resolve pass} of document rendering. +Except for the entry point @method[render% resolve] as described at +@xmethod[render<%> resolve], these methods generally would not be +called to render a document, but instead provide natural points to +interpose on the default implementation. + +A renderer for a specific format is unlikely to override any of these +methods. Each method for a document fragment within a part receives +the enclosing part as an argument, as well as resolve information as +@racket[ri] to update.} + + +@defmethod[(render [parts (listof part?)] + [dests (listof (or/c path-string? #f))] + [ri resolve-info?]) + list?] +@defmethod[(render-one [part part?] + [ri resolve-info?] + [dest (or/c path-string? #f)]) + any/c] +@defmethod[(render-part [p part?] + [ri resolve-info?]) + any/c] +@defmethod[(render-part-content [p part?] + [ri resolve-info?]) + any/c] +@defmethod[(render-flow [bs (listof block?)] + [enclosing-p part?] + [ri resolve-info?] + [first-in-part-or-item? boolean?]) + any/c] +@defmethod[(render-block [b block?] + [enclosing-p part?] + [ri resolve-info?] + [first-in-part-or-item? boolean?]) + any/c] +@defmethod[(render-nested-flow [nf nested-flow?] + [enclosing-p part?] + [ri resolve-info?] + [first-in-part-or-item? boolean?]) + any/c] +@defmethod[(render-table [t table?] + [enclosing-p part?] + [ri resolve-info?] + [first-in-part-or-item? boolean?]) + any/c] +@defmethod[(render-auxiliary-table [t table?] + [enclosing-p part?] + [ri resolve-info?]) + any/c] +@defmethod[(render-itemization [i itemization?] + [enclosing-p part?] + [ri resolve-info?]) + any/c] +@defmethod[(render-compound-paragraph [cp compound-paragraph?] + [enclosing-p part?] + [ri resolve-info?] + [first-in-part-or-item? boolean?]) + any/c] +@defmethod[(render-intrapara-block [p paragraph?] + [enclosing-p part?] + [ri resolve-info?] + [first-in-compound-paragraph? boolean?] + [last-in-compound-paragraph? boolean?] + [first-in-part-or-item? boolean?]) + any/c] +@defmethod[(render-paragraph [p paragraph?] + [enclosing-p part?] + [ri resolve-info?]) + any/c] +@defmethod[(render-content [c content?] + [enclosing-p part?] + [ri resolve-info?]) + any/c] +@defmethod[(render-other [c (and/c content? (not/c element?) (not/c convertible?))] + [enclosing-p part?] + [ri resolve-info?]) + any/c]{ + +These methods implement the @tech{render pass} of document rendering. +Except for the entry point @method[render% render] as described at +@xmethod[render<%> render], these methods generally would not be +called to render a document, but instead provide natural points to +interpose on the default implementation. + +A renderer for a specific format is likely to override most or all of +these methods. The result of each method can be anything, and the +default implementations of the methods propagate results and collect +them into a list as needed. The value of @racket[current-output-port] +is set by @method[render% render] for each immediate @racket[part] +before calling @method[render% render-one], so methods might +individually print to render, or they might return values that are +used both other methods to print. The interposition points for this +pass are somewhat different than for other passes: + +@itemlist[ + + @item{@method[render% render-one] is called by the @method[render% + render] method on each immediate @racket[part] in the list for + its first argument.} + + @item{@method[render% render-auxiliary-table] is called by the + default @method[render% render-block] on any @racket[table] + that has the @racket['aux] @tech{style property}.} + + @item{@method[render% render-intrapara-block] is called on blocks + within a @racket[compound-paragraph], where the default + implementation just chains to @racket[render% render-block].} + + + @item{@method[render% render-other] is called by the default + implementation of @racket[render-content] for any content that + does not satisfy @racket[element?] or @racket[convertible?].} + +]} + +} @; ---------------------------------------- diff -Nru racket-7.2+ppa2/share/pkgs/scribble-html-lib/info.rkt racket-7.3+ppa1/share/pkgs/scribble-html-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/scribble-html-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/scribble-html-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/scribble-lib/info.rkt racket-7.3+ppa1/share/pkgs/scribble-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/scribble-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/scribble-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.29"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.3"))) (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.29"))) diff -Nru racket-7.2+ppa2/share/pkgs/scribble-lib/scribble/acmart/acmart.cls racket-7.3+ppa1/share/pkgs/scribble-lib/scribble/acmart/acmart.cls --- racket-7.2+ppa2/share/pkgs/scribble-lib/scribble/acmart/acmart.cls 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/scribble-lib/scribble/acmart/acmart.cls 2019-05-16 01:29:07.000000000 +0000 @@ -37,7 +37,7 @@ %% Right brace \} Tilde \~} \NeedsTeXFormat{LaTeX2e} \ProvidesClass{acmart} -[2018/07/16 v1.54 Typesetting articles for the Association for +[2018/08/12 v1.55 Typesetting articles for the Association for Computing Machinery] \def\@classname{acmart} \InputIfFileExists{acmart-preload-hook.tex}{% @@ -260,7 +260,7 @@ \def\@tempb{compress}\ifx\@tempa\@tempb \def\NAT@cmprs{\@ne}\fi \def\@tempb{nocompress}\ifx\@tempa\@tempb - \def\NAT@cmprs{\@z}\fi + \def\NAT@cmprs{\z@}\fi \def\@tempb{sort&compress}\ifx\@tempa\@tempb \def\NAT@sort{\@ne}\def\NAT@cmprs{\@ne}\fi \def\@tempb{mcite}\ifx\@tempa\@tempb @@ -2159,14 +2159,15 @@ \def\@mkbibcitation{\bgroup \def\@pages@word{\ifnum\getrefnumber{TotPages}=1\relax page\else pages\fi}% \def\footnotemark{}% - \def\\{\unskip{}, \ignorespaces}% + \def\\{\unskip{} \ignorespaces}% \def\footnote{\ClassError{\@classname}{Please do not use footnotes inside a \string\title{} or \string\author{} command! Use \string\titlenote{} or \string\authornote{} instead!}}% \def\@article@string{\ifx\@acmArticle\@empty{\ }\else, Article~\@acmArticle\ \fi}% \par\medskip\small\noindent{\bfseries ACM Reference Format:}\par\nobreak - \noindent\authors. \@acmYear. \@title + \noindent\bgroup + \def\\{\unskip{}, \ignorespaces}\authors\egroup. \@acmYear. \@title \ifx\@subtitle\@empty. \else: \@subtitle. \fi \if@ACM@nonacm\else % The 'nonacm' option disables 'printacmref' by default, diff -Nru racket-7.2+ppa2/share/pkgs/scribble-lib/scribble/base-render.rkt racket-7.3+ppa1/share/pkgs/scribble-lib/scribble/base-render.rkt --- racket-7.2+ppa2/share/pkgs/scribble-lib/scribble/base-render.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/scribble-lib/scribble/base-render.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -745,7 +745,7 @@ ri)) (define/public (start-resolve ds fns ri) - (map (lambda (d) (resolve-part d ri)) ds)) + (for-each (lambda (d) (resolve-part d ri)) ds)) (define/public (resolve-part d ri) (parameterize ([current-tag-prefixes diff -Nru racket-7.2+ppa2/share/pkgs/scribble-lib/scribble/base.rkt racket-7.3+ppa1/share/pkgs/scribble-lib/scribble/base.rkt --- racket-7.2+ppa2/share/pkgs/scribble-lib/scribble/base.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/scribble-lib/scribble/base.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -759,7 +759,7 @@ ;; and non-strings --- to a paragraph for the line: (let* ([line (indent (strs->elts line))]) (list (make-paragraph omitable-style (make-nonempty line))))) - (make-table plain (map make-line lines))) + (make-table (make-style "SVerbatim" null) (map make-line lines))) (define omitable-style (make-style 'omitable null)) diff -Nru racket-7.2+ppa2/share/pkgs/scribble-lib/scribble/html-render.rkt racket-7.3+ppa1/share/pkgs/scribble-lib/scribble/html-render.rkt --- racket-7.2+ppa2/share/pkgs/scribble-lib/scribble/html-render.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/scribble-lib/scribble/html-render.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1937,6 +1937,7 @@ (define/override (start-collect ds fns ci) (parameterize ([current-part-files (make-hash)]) (for-each (lambda (d fn) + (check-duplicate-filename fn) (parameterize ([collecting-sub (if (part-style? d 'non-toc) 1 diff -Nru racket-7.2+ppa2/share/pkgs/scribble-lib/scribble/latex-render.rkt racket-7.3+ppa1/share/pkgs/scribble-lib/scribble/latex-render.rkt --- racket-7.2+ppa2/share/pkgs/scribble-lib/scribble/latex-render.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/scribble-lib/scribble/latex-render.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1136,6 +1136,7 @@ [(#\↓) "$\\downarrow$"] [(#\⇒) "$\\Rightarrow$"] [(#\→) "$\\rightarrow$"] + [(#\⟶) "$\\longrightarrow$"] [(#\↘) "$\\searrow$"] [(#\↙) "$\\swarrow$"] [(#\←) "$\\leftarrow$"] diff -Nru racket-7.2+ppa2/share/pkgs/scribble-lib/scribble/scribble.css racket-7.3+ppa1/share/pkgs/scribble-lib/scribble/scribble.css --- racket-7.2+ppa2/share/pkgs/scribble-lib/scribble/scribble.css 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/scribble-lib/scribble/scribble.css 2019-05-16 01:29:07.000000000 +0000 @@ -452,6 +452,10 @@ border: 0; } +.SVerbatim { + white-space: nowrap; +} + .SAuthorListBox { position: relative; float: right; diff -Nru racket-7.2+ppa2/share/pkgs/scribble-lib/scribble/scribble.tex racket-7.3+ppa1/share/pkgs/scribble-lib/scribble/scribble.tex --- racket-7.2+ppa2/share/pkgs/scribble-lib/scribble/scribble.tex 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/scribble-lib/scribble/scribble.tex 2019-05-16 01:29:07.000000000 +0000 @@ -387,6 +387,9 @@ % Helper for box-mode macros: \newcommand{\Svcenter}[1]{$\vcenter{#1}$} +% Verbatim +\newenvironment{SVerbatim}{}{} + % Helper to work around a problem with "#"s for URLs within \href % within other macros: \newcommand{\Shref}[3]{\href{#1\##2}{#3}} diff -Nru racket-7.2+ppa2/share/pkgs/scribble-text-lib/info.rkt racket-7.3+ppa1/share/pkgs/scribble-text-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/scribble-text-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/scribble-text-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/serialize-cstruct-lib/info.rkt racket-7.3+ppa1/share/pkgs/serialize-cstruct-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/serialize-cstruct-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/serialize-cstruct-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/sgl/info.rkt racket-7.3+ppa1/share/pkgs/sgl/info.rkt --- racket-7.2+ppa2/share/pkgs/sgl/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/sgl/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/shell-completion/info.rkt racket-7.3+ppa1/share/pkgs/shell-completion/info.rkt --- racket-7.2+ppa2/share/pkgs/shell-completion/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/shell-completion/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/slatex/info.rkt racket-7.3+ppa1/share/pkgs/slatex/info.rkt --- racket-7.2+ppa2/share/pkgs/slatex/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/slatex/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/slideshow/info.rkt racket-7.3+ppa1/share/pkgs/slideshow/info.rkt --- racket-7.2+ppa2/share/pkgs/slideshow/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/slideshow/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/slideshow-doc/info.rkt racket-7.3+ppa1/share/pkgs/slideshow-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/slideshow-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/slideshow-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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" "at-exp-lib"))) (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.3"))) (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" "at-exp-lib"))) (define update-implies (quote ("slideshow-lib"))) (define pkg-desc "documentation part of \"slideshow\"") (define pkg-authors (quote (mflatt robby))))) diff -Nru racket-7.2+ppa2/share/pkgs/slideshow-exe/info.rkt racket-7.3+ppa1/share/pkgs/slideshow-exe/info.rkt --- racket-7.2+ppa2/share/pkgs/slideshow-exe/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/slideshow-exe/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/slideshow-lib/info.rkt racket-7.3+ppa1/share/pkgs/slideshow-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/slideshow-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/slideshow-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.5"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.3"))) (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.5"))) diff -Nru racket-7.2+ppa2/share/pkgs/slideshow-plugin/info.rkt racket-7.3+ppa1/share/pkgs/slideshow-plugin/info.rkt --- racket-7.2+ppa2/share/pkgs/slideshow-plugin/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/slideshow-plugin/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/snip/info.rkt racket-7.3+ppa1/share/pkgs/snip/info.rkt --- racket-7.2+ppa2/share/pkgs/snip/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/snip/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/snip-lib/info.rkt racket-7.3+ppa1/share/pkgs/snip-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/snip-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/snip-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/snip-lib/racket/snip/private/snip.rkt racket-7.3+ppa1/share/pkgs/snip-lib/racket/snip/private/snip.rkt --- racket-7.2+ppa2/share/pkgs/snip-lib/racket/snip/private/snip.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/snip-lib/racket/snip/private/snip.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -177,7 +177,8 @@ width-depends-on-y height-depends-on-x handles-all-mouse-events - handles-between-events)) + handles-between-events + uses-editor-path)) new-flags]) (s-set-flags (symbols->flags new-flags))) diff -Nru racket-7.2+ppa2/share/pkgs/source-syntax/info.rkt racket-7.3+ppa1/share/pkgs/source-syntax/info.rkt --- racket-7.2+ppa2/share/pkgs/source-syntax/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/source-syntax/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/srfi/info.rkt racket-7.3+ppa1/share/pkgs/srfi/info.rkt --- racket-7.2+ppa2/share/pkgs/srfi/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/srfi/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.3"))) (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-7.2+ppa2/share/pkgs/srfi-doc/info.rkt racket-7.3+ppa1/share/pkgs/srfi-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/srfi-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/srfi-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.3"))) (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-7.2+ppa2/share/pkgs/srfi-lib/info.rkt racket-7.3+ppa1/share/pkgs/srfi-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/srfi-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/srfi-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/srfi-lib-nonfree/info.rkt racket-7.3+ppa1/share/pkgs/srfi-lib-nonfree/info.rkt --- racket-7.2+ppa2/share/pkgs/srfi-lib-nonfree/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/srfi-lib-nonfree/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "base" "r6rs-lib" "srfi-lib" "compatibility-lib"))) (define pkg-desc "implementation (no documentation) part of \"srfi nonfree\"") (define pkg-authors (quote (mflatt noel chongkai jay))))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.3"))) (define collection (quote multi)) (define deps (quote ("scheme-lib" "base" "r6rs-lib" "srfi-lib" "compatibility-lib"))) (define pkg-desc "implementation (no documentation) part of \"srfi nonfree\"") (define pkg-authors (quote (mflatt noel chongkai jay))))) diff -Nru racket-7.2+ppa2/share/pkgs/srfi-lite-lib/info.rkt racket-7.3+ppa1/share/pkgs/srfi-lite-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/srfi-lite-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/srfi-lite-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (define collection (quote multi)) (define deps (quote ("base"))) (define pkg-desc "implementation of the most widely used \"srfi\" libraries") (define pkg-authors (quote (mflatt))))) diff -Nru racket-7.2+ppa2/share/pkgs/string-constants/info.rkt racket-7.3+ppa1/share/pkgs/string-constants/info.rkt --- racket-7.2+ppa2/share/pkgs/string-constants/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/string-constants/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/string-constants-doc/info.rkt racket-7.3+ppa1/share/pkgs/string-constants-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/string-constants-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/string-constants-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/string-constants-lib/info.rkt racket-7.3+ppa1/share/pkgs/string-constants-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/string-constants-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/string-constants-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.21"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.3"))) (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.23"))) diff -Nru racket-7.2+ppa2/share/pkgs/string-constants-lib/string-constants/private/bulgarian-string-constants.rkt racket-7.3+ppa1/share/pkgs/string-constants-lib/string-constants/private/bulgarian-string-constants.rkt --- racket-7.2+ppa2/share/pkgs/string-constants-lib/string-constants/private/bulgarian-string-constants.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/string-constants-lib/string-constants/private/bulgarian-string-constants.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1,6 +1,6 @@ -;; Bulgarian translation of Racket string constants file, version: 1.20 +;; Bulgarian translation of Racket string constants file, version: 1.22 ;; This file is distributed under the same terms as Racket -;; Copyright on translation: Alexander Shopov , 2015, 2016, 2017, 2018. +;; Copyright on translation: Alexander Shopov , 2015, 2016, 2017, 2018, 2019. (module bulgarian-string-constants "string-constant-lang.rkt" ;;; when translating this constant, substitute name of actual language for `English' @@ -103,6 +103,10 @@ (cs-italic "Курсив") (cs-bold "Получерно") (cs-underline "Подчертаване") + (cs-smoothing-default "Default") + (cs-smoothing-partial "Partly smoothed") + (cs-smoothing-full "Smoothed") + (cs-smoothing-none "Unsmoothed") (cs-change-color "Смяна на цвета") (cs-foreground-color "Основен цвят") (cs-background-color "Цвят на фона") diff -Nru racket-7.2+ppa2/share/pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt racket-7.3+ppa1/share/pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt --- racket-7.2+ppa2/share/pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -184,11 +184,23 @@ (malformed-email-address "Malformed email address") (pls-fill-in-either-description-or-reproduce "Please fill in either the Description field or the Steps to Reproduce field.") + (have-an-issue? "Having an issue? ...") + (use-github-or-the-mailing-list-for-issues + "If you have found a bug in Racket or DrRacket, please open an issue on GitHub.\n\nIf" + " you found something that does not make sense, but you are not sure if it is" + " a bug or not, try asking on the mailing list.") + (visit-github "Visit GitHub") + (visit-mailing-list "Visit Mailing Lists") + ;;; check syntax (check-syntax "Check Syntax") (cs-italic "Italic") (cs-bold "Bold") (cs-underline "Underline") + (cs-smoothing-default "Default") + (cs-smoothing-partial "Partly smoothed") + (cs-smoothing-full "Smoothed") + (cs-smoothing-none "Unsmoothed") (cs-change-color "Change Color") (cs-foreground-color "Foreground Color") (cs-background-color "Background Color") diff -Nru racket-7.2+ppa2/share/pkgs/string-constants-lib/string-constants/private/french-string-constants.rkt racket-7.3+ppa1/share/pkgs/string-constants-lib/string-constants/private/french-string-constants.rkt --- racket-7.2+ppa2/share/pkgs/string-constants-lib/string-constants/private/french-string-constants.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/string-constants-lib/string-constants/private/french-string-constants.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1112,6 +1112,7 @@ (stand-alone-explanatory-label "Autonome (pour cette machine uniquement, exécution d'une copie compilée)") (distribution "Distribution") (distribution-explanatory-label "Distribution (pour installation sur d'autres machines)") + (embed-dlls? "Insérer les DLLs dans l'exécutable ?") ;; appears in the GUI only under windows (executable-type "Type") (executable-base "Base") (filename "Nom de fichier : ") @@ -1709,10 +1710,18 @@ ; printed specially in DrRacket. (test-engine-check-encountered-error "check-expect a rencontré l'erreur suivante au lieu de la valeur attendue, ~F. ~n :: ~a") + (test-engine-check-error-cause + "causée par l'expression") (test-engine-actual-value-differs-error "La valeur actuelle ~F est différente de ~F, la valeur attendue.") + ;; need to translate only one of these next two + ;; (test-engine-actual-value-not-within-error or + ;; test-engine-actual-value-not-within-error/alt-word-order) + ;; if both are present, test-engine-actual-value-not-within-error is used (test-engine-actual-value-not-within-error - "La valeur actualle ~F n'est pas à moins de ~v de la valeur attendue ~F.") + "La valeur actuelle ~F n'est pas à moins de ~v de la valeur attendue ~F.") + (test-engine-actual-value-not-within-error/alt-order + "La valeur actuelle ~F n'est pas assez proche de la valeur attendue ~F ; elle aurait du être à moins de ~v de la valeur attendue.") (test-engine-encountered-error-error "check-error a rencontré l'erreur suivante au lieu du ~a attendu~n :: ~a") (test-engine-expected-error-error diff -Nru racket-7.2+ppa2/share/pkgs/string-constants-lib/string-constants/private/german-string-constants.rkt racket-7.3+ppa1/share/pkgs/string-constants-lib/string-constants/private/german-string-constants.rkt --- racket-7.2+ppa2/share/pkgs/string-constants-lib/string-constants/private/german-string-constants.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/string-constants-lib/string-constants/private/german-string-constants.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -89,6 +89,10 @@ (cs-italic "Kursiv") (cs-bold "Fett") (cs-underline "Unterstrichen") + (cs-smoothing-default "Standard") + (cs-smoothing-partial "Teilweise geglättet") + (cs-smoothing-full "Geglättet") + (cs-smoothing-none "Ungeglättet") (cs-change-color "Farbe ändern") (cs-foreground-color "Vordergrundfarbe") (cs-background-color "Hintergrundfarbe") @@ -387,7 +391,10 @@ ;;; save file in particular format prompting. (save-as-plain-text "Diese Datei als Text speichern?") + (save-as-binary-format "Diese Datei in ein DrRacket-spezifisches Format konvertieren, um die Nicht-Text-Elemente zu erhalten??") (save-in-drs-format "Diese Datei im DrRacket-Format (kein Text) speichern?") + (keep-format "Behalten (Datenverlust möglich)") + (convert-format "Konvertieren (empfohlen)") (yes "Ja") (no "Nein") @@ -909,7 +916,7 @@ ;;; file menu (save-definitions-as "Definitionen speichern unter…") (save-definitions "Definitionen speichern") - (print-definitions "Definition drucken…") + (print-definitions "Definitionen drucken…") (about-drscheme "Über DrRacket") (save-other "Speichern unter") (save-definitions-as-text "Definitionen als Text speichern…") @@ -1433,7 +1440,7 @@ (stepper-no-selected-step "Keine Schritte im markierten Bereich. Vielleicht ist es auskommentiert?") - (stepper-no-last-step "Der letzte Schritt ist nocht nicht verfügbar.") + (stepper-no-last-step "Der letzte Schritt ist noch nicht verfügbar.") (debug-tool-button-name "Debugger") @@ -1590,6 +1597,8 @@ "Der tatsächliche Wert ~F ist nicht der erwartete Wert ~F.") (test-engine-actual-value-not-within-error "Der tatsächliche Wert ~F ist nicht innerhalb von ~v des erwarteten Werts ~F.") + (test-engine-actual-value-not-within-error/alt-order + "Der tatsächliche Wert ~F ist nicht nah genug am erwarteten Wert ~F; erwartet innerhalb von ~v.") (test-engine-encountered-error-error "check-error bekam den folgenden Fehler anstatt des erwarteten ~a~n :: ~a") (test-engine-expected-error-error diff -Nru racket-7.2+ppa2/share/pkgs/swindle/info.rkt racket-7.3+ppa1/share/pkgs/swindle/info.rkt --- racket-7.2+ppa2/share/pkgs/swindle/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/swindle/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/syntax-color/info.rkt racket-7.3+ppa1/share/pkgs/syntax-color/info.rkt --- racket-7.2+ppa2/share/pkgs/syntax-color/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/syntax-color/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/syntax-color-doc/info.rkt racket-7.3+ppa1/share/pkgs/syntax-color-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/syntax-color-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/syntax-color-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/syntax-color-lib/info.rkt racket-7.3+ppa1/share/pkgs/syntax-color-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/syntax-color-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/syntax-color-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/testing-util-lib/info.rkt racket-7.3+ppa1/share/pkgs/testing-util-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/testing-util-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/testing-util-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/tex-table/info.rkt racket-7.3+ppa1/share/pkgs/tex-table/info.rkt --- racket-7.2+ppa2/share/pkgs/tex-table/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/tex-table/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (define deps (quote ("base"))) (define collection "mrlib") (define pkg-desc "Table of TeX-style abbreviations") (define pkg-authors (quote (robby))))) diff -Nru racket-7.2+ppa2/share/pkgs/tex-table/tex-table.rkt racket-7.3+ppa1/share/pkgs/tex-table/tex-table.rkt --- racket-7.2+ppa2/share/pkgs/tex-table/tex-table.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/tex-table/tex-table.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -26,7 +26,7 @@ ("leftarrow" "←") ("uparrow" "↑") ("Leftarrow" "⇐") - ("longrightarrow" "−") + ("longrightarrow" "⟶") ("Uparrow" "⇑") ("Leftrightarrow" "⇔") ("updownarrow" "↕") diff -Nru racket-7.2+ppa2/share/pkgs/trace/info.rkt racket-7.3+ppa1/share/pkgs/trace/info.rkt --- racket-7.2+ppa2/share/pkgs/trace/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/trace/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/typed-racket/info.rkt racket-7.3+ppa1/share/pkgs/typed-racket/info.rkt --- racket-7.2+ppa2/share/pkgs/typed-racket/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/typed-racket/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.10"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.3"))) (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.10"))) diff -Nru racket-7.2+ppa2/share/pkgs/typed-racket-compatibility/info.rkt racket-7.3+ppa1/share/pkgs/typed-racket-compatibility/info.rkt --- racket-7.2+ppa2/share/pkgs/typed-racket-compatibility/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/typed-racket-compatibility/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.3"))) (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-7.2+ppa2/share/pkgs/typed-racket-doc/info.rkt racket-7.3+ppa1/share/pkgs/typed-racket-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/typed-racket-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/typed-racket-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.10") "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.10"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.3"))) (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.10") "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.10"))) diff -Nru racket-7.2+ppa2/share/pkgs/typed-racket-lib/info.rkt racket-7.3+ppa1/share/pkgs/typed-racket-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/typed-racket-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/typed-racket-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.10"))) +(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.3"))) (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.10"))) diff -Nru racket-7.2+ppa2/share/pkgs/typed-racket-lib/typed-racket/base-env/base-env-numeric.rkt racket-7.3+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/base-env-numeric.rkt --- racket-7.2+ppa2/share/pkgs/typed-racket-lib/typed-racket/base-env/base-env-numeric.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/base-env-numeric.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1498,7 +1498,7 @@ ;; no positive / negative cases, possible underflow (-NonNegReal . -> . -NonNegSingleFlonum) (-NonPosReal . -> . -NonPosSingleFlonum) - (-Real . -> . -SingleFlonumZero))] + (-Real . -> . -SingleFlonum))] [real->double-flonum (from-cases (map unop all-flonum-types) (-SingleFlonumPosZero . -> . -FlonumPosZero) diff -Nru racket-7.2+ppa2/share/pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt racket-7.3+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt --- racket-7.2+ppa2/share/pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1844,8 +1844,8 @@ [current-output-port (-Param -Output-Port -Output-Port)] [current-error-port (-Param -Output-Port -Output-Port)] -[file-stream-port? (-> Univ B)] -[terminal-port? (-> Univ B)] +[file-stream-port? (asym-pred Univ B (-PS (-is-type 0 -Port) -tt))] +[terminal-port? (asym-pred Univ B (-PS (-is-type 0 -Port) -tt))] [eof (-val eof)] [eof-object? (make-pred-ty (-val eof))] diff -Nru racket-7.2+ppa2/share/pkgs/typed-racket-lib/typed-racket/base-env/base-special-env.rkt racket-7.3+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/base-special-env.rkt --- racket-7.2+ppa2/share/pkgs/typed-racket-lib/typed-racket/base-env/base-special-env.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/base-special-env.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -373,4 +373,9 @@ (-> -Variable-Reference -Namespace-Anchor)] [(make-template-identifier 'check-logger-or-false 'racket/private/logger) (-> -Symbol Univ (Un (-val #f) -Logger))] + [(make-template-identifier 'place/proc 'racket/place) + (-> -Variable-Reference -Symbol -Symbol (-> -Symbol -Module-Path -Symbol (-opt -Input-Port) (-opt -Output-Port) (-opt -Output-Port) -Place) + (-opt -Input-Port) (-opt -Output-Port) (-opt -Output-Port) -Place)] + [(make-template-identifier 'start-place 'racket/place) + (-> -Symbol -Module-Path -Symbol (-opt -Input-Port) (-opt -Output-Port) (-opt -Output-Port) -Place)] ) diff -Nru racket-7.2+ppa2/share/pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt racket-7.3+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt --- racket-7.2+ppa2/share/pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -262,12 +262,12 @@ #'letrec-values)) (define expanded (local-expand stx (syntax-local-context) stop-list)) (define stx* - (syntax-parse expanded + (syntax-parse (disarm* expanded) #:literal-sets (kernel-literals) ;; an extra #%expression is inserted by the local expansion but ;; won't appear in the actual expansion, so ignore it [(#%expression e) #'e] - [_ expanded])) + [e #'e])) (syntax-parse stx* #:literal-sets (kernel-literals) #:literals (lambda λ) diff -Nru racket-7.2+ppa2/share/pkgs/typed-racket-lib/typed-racket/HISTORY.txt racket-7.3+ppa1/share/pkgs/typed-racket-lib/typed-racket/HISTORY.txt --- racket-7.2+ppa2/share/pkgs/typed-racket-lib/typed-racket/HISTORY.txt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/typed-racket-lib/typed-racket/HISTORY.txt 2019-05-16 01:29:07.000000000 +0000 @@ -1,3 +1,7 @@ +7.3 +- Bug fixes and type updates. +7.2 +- Bug fixes and type updates. 7.1 - Add immutable vectors. 7.0 diff -Nru racket-7.2+ppa2/share/pkgs/typed-racket-lib/typed-racket/infer/infer-unit.rkt racket-7.3+ppa1/share/pkgs/typed-racket-lib/typed-racket/infer/infer-unit.rkt --- racket-7.2+ppa2/share/pkgs/typed-racket-lib/typed-racket/infer/infer-unit.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/typed-racket-lib/typed-racket/infer/infer-unit.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -479,13 +479,15 @@ [((or (Values: (list (Result: _ psets _) ...)) (ValuesDots: (list (Result: _ psets _) ...) _ _)) (AnyValues: q)) - (cset-join - (for*/list ([pset (in-list psets)] - [cs (in-value (% cset-meet - (cgen/prop context (PropSet-thn pset) q) - (cgen/prop context (PropSet-els pset) q)))] - #:when cs) - cs))] + (if (null? psets) + empty + (cset-join + (for*/list ([pset (in-list psets)] + [cs (in-value (% cset-meet + (cgen/prop context (PropSet-thn pset) q) + (cgen/prop context (PropSet-els pset) q)))] + #:when cs) + cs)))] ;; check all non Type? first so that calling subtype is safe diff -Nru racket-7.2+ppa2/share/pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt racket-7.3+ppa1/share/pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt --- racket-7.2+ppa2/share/pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/typed-racket-lib/typed-racket/private/parse-type.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -100,7 +100,7 @@ ;; code in type-alias-helper.rkt calls `parse-type` for effect to build up -;; info about how types depend on eachother -- during this parsing, we can't +;; info about how types depend on each other -- during this parsing, we can't ;; check certain invariant successfully (i.e. when a user writes `(car p)` ;; `p` is <: (Pair Any Any), etc), so we use this flag to disable/enable ;; invariant checking while parsing diff -Nru racket-7.2+ppa2/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt racket-7.3+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt --- racket-7.2+ppa2/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -323,7 +323,7 @@ (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)) + (define rng (instantiate-obj raw-rng names)) (let ([fcn-string (name->function-str name)]) (if (and (null? domain) (null? argtypes)) diff -Nru racket-7.2+ppa2/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-funapp.rkt racket-7.3+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-funapp.rkt --- racket-7.2+ppa2/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-funapp.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/typed-racket-lib/typed-racket/typecheck/tc-funapp.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -107,7 +107,7 @@ (check-below arg-res (ret dom-t)))) (unless (implies-in-env? (lexical-env) -tt pre) (tc-error/fields "could not apply function" - #:more "unable to prove precondition" + #:more "unable to prove" "precondition" pre #:delayed? #t)) rng))] @@ -232,7 +232,7 @@ (subst-dom-objs argtys argobjs raw-pre))) (unless (implies-in-env? (lexical-env) -tt pre) (tc-error/fields "could not apply function" - #:more "unable to prove precondition" + #:more "unable to prove" "precondition" pre #:delayed? #t)) (values->tc-results/explicit-subst diff -Nru racket-7.2+ppa2/share/pkgs/typed-racket-lib/typed-racket/utils/redirect-contract.rkt racket-7.3+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/redirect-contract.rkt --- racket-7.2+ppa2/share/pkgs/typed-racket-lib/typed-racket/utils/redirect-contract.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/redirect-contract.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -2,7 +2,8 @@ (require syntax/private/modcollapse-noctc syntax/private/id-table - (for-template racket/base)) + (for-template racket/base) + "disarm.rkt") (provide make-make-redirect-to-contract) ;; This is used to define identifiers that expand to a local-require @@ -28,7 +29,8 @@ (define id-table (make-free-id-table)) -(define ((make-make-redirect-to-contract contract-defs-submod-modidx) id) +(define ((make-make-redirect-to-contract contract-defs-submod-modidx) orig-id) + (define id (disarm* orig-id)) (define (redirect stx) (cond [(identifier? stx) diff -Nru racket-7.2+ppa2/share/pkgs/typed-racket-lib/typed-racket/utils/utils.rkt racket-7.3+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/utils.rkt --- racket-7.2+ppa2/share/pkgs/typed-racket-lib/typed-racket/utils/utils.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/typed-racket-lib/typed-racket/utils/utils.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -10,7 +10,8 @@ racket/match racket/list syntax/parse/define - racket/struct-info "timing.rkt") + racket/struct-info "timing.rkt" + "disarm.rkt") (provide ;; optimization @@ -217,7 +218,7 @@ ;FIXME when multiple bindings are supported (define (self-ctor-transformer orig stx) (define (transfer-srcloc orig stx) - (datum->syntax orig (syntax-e orig) stx orig)) + (datum->syntax (disarm* orig) (syntax-e orig) stx orig)) (syntax-case stx () [(self arg ...) (datum->syntax stx (cons (syntax-property (transfer-srcloc orig #'self) diff -Nru racket-7.2+ppa2/share/pkgs/typed-racket-more/info.rkt racket-7.3+ppa1/share/pkgs/typed-racket-more/info.rkt --- racket-7.2+ppa2/share/pkgs/typed-racket-more/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/typed-racket-more/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (define collection (quote multi)) (define deps (quote ("srfi-lite-lib" "base" "net-lib" "web-server-lib" ("db-lib" #:version "1.5") "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-7.2+ppa2/share/pkgs/typed-racket-more/typed/db/base.rkt racket-7.3+ppa1/share/pkgs/typed-racket-more/typed/db/base.rkt --- racket-7.2+ppa2/share/pkgs/typed-racket-more/typed/db/base.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/typed-racket-more/typed/db/base.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -15,7 +15,7 @@ (define-type SQL-Datum (U Boolean String Real Char Bytes SQL-Null)) (define-type SQL-Type (List Boolean (Option Symbol) SQL-Datum)) -(define-type Statement (U String Prepared-Statement Virtual-Statement Statement-Binding)) +(define-type Statement (U String Prepared-Statement Virtual-Statement Statement-Binding Other-Statement)) (define-type SQL-Field (U String Natural)) (define-type SQL-Grouping (U SQL-Field (Vectorof SQL-Field))) @@ -97,6 +97,7 @@ [#:opaque Prepared-Statement prepared-statement?] [#:opaque Virtual-Statement virtual-statement?] [#:opaque Statement-Binding statement-binding?] + [#:opaque Other-Statement prop:statement?] [prepare (-> Connection (U String Virtual-Statement) Prepared-Statement)] [prepared-statement-parameter-types (-> Prepared-Statement (Listof SQL-Type))] [prepared-statement-result-types (-> Prepared-Statement (Listof SQL-Type))] @@ -108,7 +109,8 @@ (or (string? s) (prepared-statement? s) (statement-binding? s) - (virtual-statement? s)))) + (virtual-statement? s) + (prop:statement? s)))) (require/typed/provide db/base diff -Nru racket-7.2+ppa2/share/pkgs/typed-racket-more/typed/net/sendmail.rkt racket-7.3+ppa1/share/pkgs/typed-racket-more/typed/net/sendmail.rkt --- racket-7.2+ppa2/share/pkgs/typed-racket-more/typed/net/sendmail.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/typed-racket-more/typed/net/sendmail.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -6,6 +6,6 @@ [send-mail-message/port (String String (Listof String) (Listof String) (Listof String) String * -> Output-Port)] [send-mail-message - (String String (Listof String) (Listof String) (Listof String) (Listof String) String * -> Output-Port)]) + (String String (Listof String) (Listof String) (Listof String) (Listof String) String * -> Void)]) (provide send-mail-message/port send-mail-message #;no-mail-recipients) diff -Nru racket-7.2+ppa2/share/pkgs/unix-socket/info.rkt racket-7.3+ppa1/share/pkgs/unix-socket/info.rkt --- racket-7.2+ppa2/share/pkgs/unix-socket/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/unix-socket/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/unix-socket-doc/info.rkt racket-7.3+ppa1/share/pkgs/unix-socket-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/unix-socket-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/unix-socket-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/unix-socket-lib/info.rkt racket-7.3+ppa1/share/pkgs/unix-socket-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/unix-socket-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/unix-socket-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (define collection (quote multi)) (define version "1.2") (define deps (quote (("base" #:version "7.2.0.6")))) (define pkg-authors (quote (ryanc))))) diff -Nru racket-7.2+ppa2/share/pkgs/unix-socket-lib/racket/private/unix-socket-ffi.rkt racket-7.3+ppa1/share/pkgs/unix-socket-lib/racket/private/unix-socket-ffi.rkt --- racket-7.2+ppa2/share/pkgs/unix-socket-lib/racket/private/unix-socket-ffi.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/unix-socket-lib/racket/private/unix-socket-ffi.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -12,12 +12,9 @@ (case (system-type 'os) [(macosx) 'bsd] [(unix) - (define machine - ;; security guard may prevent executing uname - (with-handlers ([exn:fail? (lambda (e) "unknown")]) - (system-type 'machine))) - (cond [(regexp-match? #rx"^Linux" machine) 'linux] - [(regexp-match? #rx"^[a-zA-Z]*BSD" machine) 'bsd] + (define sys (path->string (system-library-subpath #f))) + (cond [(regexp-match? #rx"-linux$" sys) 'linux] + [(regexp-match? #rx"bsd$" sys) 'bsd] [else #f])] [else #f])) @@ -154,8 +151,8 @@ ;; Racket constants and functions ;; indirection to support testing; see below -(define (socket->semaphore fd mode) - (unsafe-socket->semaphore fd mode)) +(define (fd->evt fd mode) + (unsafe-fd->evt fd mode #t)) ;; ============================================================ ;; Testing @@ -172,7 +169,7 @@ (when #f ;; -- mock for connect returning EINPROGRESS (let ([real-connect connect] - [real-socket->semaphore socket->semaphore]) + [real-fd->evt fd->evt]) ;; connecting-fds : hash[nat => #t] (define connecting-fds (make-hash)) (set! connect @@ -184,7 +181,7 @@ (eprintf "** mock connect: setting EINPROGRESS\n") -1] [else r]))) - (set! socket->semaphore + (set! fd->evt (lambda (fd kind) (cond [(and (eq? kind 'write) (hash-ref connecting-fds fd #f)) @@ -197,14 +194,14 @@ (hash-remove! connecting-fds fd) sema] [else - (real-socket->semaphore fd kind)]))))) + (real-fd->evt fd kind)]))))) ;; mock for accept returning EWOULDBLOCK/EAGAIN no longer works, ;; probably because doesn't intercept unsafe-poll-ctx-fd-wakeup (when #f ;; - mock for accept returning EWOULDBLOCK/EAGAIN (let ([real-accept accept] - [real-socket->semaphore socket->semaphore]) + [real-fd->evt fd->evt]) ;; accepting-fds : hash[nat => #t] (define accepting-fds (make-hash)) (set! accept @@ -217,7 +214,7 @@ (hash-set! accepting-fds s #t) (saved-errno EWOULDBLOCK) -1]))) - (set! socket->semaphore + (set! fd->evt (lambda (fd kind) (cond [(and (eq? kind 'read) (hash-ref accepting-fds fd #f)) @@ -229,4 +226,4 @@ (semaphore-post sema))) sema] [else - (real-socket->semaphore fd kind)]))))) + (real-fd->evt fd kind)]))))) diff -Nru racket-7.2+ppa2/share/pkgs/unix-socket-lib/racket/unix-socket.rkt racket-7.3+ppa1/share/pkgs/unix-socket-lib/racket/unix-socket.rkt --- racket-7.2+ppa2/share/pkgs/unix-socket-lib/racket/unix-socket.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/unix-socket-lib/racket/unix-socket.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -80,7 +80,7 @@ ;; close/unregister : Nat Cust-Reg/#f -> Void (define (close/unregister fd [reg #f]) (close fd) - (socket->semaphore fd 'remove) + (fd->evt fd 'remove) (when reg (unregister-custodian-shutdown fd reg))) ;; make-socket-ports : Symbol FD Cust-Reg/#f -> (values Input-Port Output-Port) @@ -172,9 +172,9 @@ (define-values (in out) (make-socket-ports 'unix-socket-connect socket-fd reg)) (lambda () (values in out))] [(= errno EINPROGRESS) ;; wait and see - (define sema (socket->semaphore socket-fd 'write)) + (define ready-evt (fd->evt socket-fd 'write)) (lambda () ;; called in non-atomic mode! - (sync sema) + (sync ready-evt) ;; FIXME: check custodian hasn't been shut down? (call-as-atomic (lambda () @@ -209,10 +209,10 @@ (lambda () (wrap-evt ;; ready when fd is readable OR listener is closed - ;; If closed after evt creation, then fd-sema becomes ready - ;; when fd closed and fd-sema unregistered. + ;; If closed after evt creation, then fd-evt becomes ready + ;; when fd closed and fd-evt is unregistered. (cond [(unix-socket-listener-fd self) - => (lambda (fd) (socket->semaphore fd 'read))] + => (lambda (fd) (fd->evt fd 'read))] [else always-evt]) (lambda (r) self)))))) @@ -280,8 +280,8 @@ [else (accept-poll/check who accept-evt lfd)])])) (define (accept-poll/sleep who accept-evt wakeups lfd) - ;; No need to register wakeup for custodian; if custodian is shut down, then - ;; lfd semaphore becomes ready when it is unregistered + ;; No need to register wakeup for custodian; custodian shutdown means a Racket thread + ;; did work, so accept-evt will get re-polled. (unsafe-poll-ctx-fd-wakeup wakeups lfd 'read) (values #f accept-evt)) diff -Nru racket-7.2+ppa2/share/pkgs/web-server/info.rkt racket-7.3+ppa1/share/pkgs/web-server/info.rkt --- racket-7.2+ppa2/share/pkgs/web-server/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/web-server/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/web-server-doc/info.rkt racket-7.3+ppa1/share/pkgs/web-server-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/web-server-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/web-server-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/web-server-doc/web-server/scribblings/cache-table.scrbl racket-7.3+ppa1/share/pkgs/web-server-doc/web-server/scribblings/cache-table.scrbl --- racket-7.2+ppa2/share/pkgs/web-server-doc/web-server/scribblings/cache-table.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/web-server-doc/web-server/scribblings/cache-table.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -30,8 +30,10 @@ 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 for list of entry keys." - #:changed "6.11.0.3" "Added optional argument for finalizer procedure."] + @history[#:changed "1.3" + "Added optional argument for list of entry keys." + #:changed "1.3" + "Added optional argument for finalizer procedure."] } @defproc[(cache-table? [v any/c]) diff -Nru racket-7.2+ppa2/share/pkgs/web-server-doc/web-server/scribblings/dispatchers.scrbl racket-7.3+ppa1/share/pkgs/web-server-doc/web-server/scribblings/dispatchers.scrbl --- racket-7.2+ppa2/share/pkgs/web-server-doc/web-server/scribblings/dispatchers.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/web-server-doc/web-server/scribblings/dispatchers.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -31,6 +31,9 @@ @defthing[dispatcher/c contract?]{ Equivalent to @racket[(connection? request? . -> . any)]. + + @history[#:changed "1.3" + @elem{Weakened the range contract to allow @racket[any]}] } @defproc[(dispatcher-interface-version/c (any any/c)) boolean?]{ @@ -244,6 +247,9 @@ 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]. + + @history[#:changed "1.3" + @elem{Allow @racket[log-path] to be an @racket[output-port?]}] }} @; ------------------------------------------------------------ diff -Nru racket-7.2+ppa2/share/pkgs/web-server-doc/web-server/scribblings/dispatch-servlets.scrbl racket-7.3+ppa1/share/pkgs/web-server-doc/web-server/scribblings/dispatch-servlets.scrbl --- racket-7.2+ppa2/share/pkgs/web-server-doc/web-server/scribblings/dispatch-servlets.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/web-server-doc/web-server/scribblings/dispatch-servlets.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -25,15 +25,18 @@ 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]. + to finalize servlet resources. Beware that the default value @racket[void] + performs no finalization. In particular, it does not shut down the servlet's + custodian, instead allowing the servlet's custodian-managed resources (such + as threads) to persist. 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 for list of URLs." - #:changed "6.11.0.3" "Added optional argument to first return value for servlet finalizer procedure."] + @history[#:changed "1.3" "Added optional argument to first return value for list of URLs." + #:changed "1.3" "Added optional argument to first return value for servlet finalizer procedure."] } @defproc[(make [url->servlet url->servlet/c] diff -Nru racket-7.2+ppa2/share/pkgs/web-server-doc/web-server/scribblings/faq.scrbl racket-7.3+ppa1/share/pkgs/web-server-doc/web-server/scribblings/faq.scrbl --- racket-7.2+ppa2/share/pkgs/web-server-doc/web-server/scribblings/faq.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/web-server-doc/web-server/scribblings/faq.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -89,7 +89,7 @@ tag, e.g. @link["http://www.w3.org/TR/html401/interact/forms.html#h-17.7"]{TEXTAREA}. Similarly, XML allows an end tag, e.g. @litchar{}, on every tag, while HTML occasionally forbides an +src='...'>}, on every tag, while HTML occasionally forbids an end tag, e.g. @link["http://www.w3.org/TR/html401/struct/objects.html#h-13.2"]{IMG}. (Of course, browsers do not necessarily implement their HTML parsing diff -Nru racket-7.2+ppa2/share/pkgs/web-server-doc/web-server/scribblings/formlets.scrbl racket-7.3+ppa1/share/pkgs/web-server-doc/web-server/scribblings/formlets.scrbl --- racket-7.2+ppa2/share/pkgs/web-server-doc/web-server/scribblings/formlets.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/web-server-doc/web-server/scribblings/formlets.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -14,8 +14,8 @@ The @web-server provides a kind of Web form abstraction called a @tech{formlet}. -@margin-note{@tech{Formlet}s originate in the work of the @link["http://groups.inf.ed.ac.uk/links/"]{Links} research group in -their paper @link["http://groups.inf.ed.ac.uk/links/formlets/"]{The Essence of Form Abstraction}.} +@margin-note{@tech{Formlet}s originate in the work of the @link["http://links-lang.org"]{Links} research group in +their paper @link["http://links-lang.org/papers/formlets-essence.pdf"]{The Essence of Form Abstraction}.} @section{Basic Formlet Usage} @@ -216,12 +216,18 @@ (Actually, @racket[formlet/c] is a macro which avoids using @racket[dynamic->*] when the number of range contracts for the processing function is known at compile time.) + + @history[#:changed "1.3" + "Fixed support for multiple return values."] } @defthing[formlet*/c contract?]{ Similar to the contracts created by @racket[formlet/c], but uses @racket[any] to avoid checking the results (or even specifying the number of results) of the processing function. + + @history[#:changed "1.3" + "Fixed support for multiple return values."] } @defproc[(pure [value any/c]) (formlet/c any/c)]{ @@ -505,6 +511,11 @@ @defthing[input-int (formlet/c number?)]{ Equivalent to @racket[(to-number input-string)]. + Note that, despite the name, the result + @bold{is not guaranteed to be an integer.} + + @history[#:changed "1.3" + "Weakened result contract to allow any number."] } @defthing[input-symbol (formlet/c symbol?)]{ @@ -607,3 +618,10 @@ contracts.} As the name implies, using @racketmodname[web-server/formlets/unsafe] may produce inscrutable error messages and other unpleasant effects of programming without contracts: you have been warned. + +@history[#:changed "1.3" + @elem{Added @racketmodname[web-server/formlets/stateless] and + @racketmodname[web-server/formlets/unsafe] and + changed combinators from @racketmodname[web-server/formlets] + to produce serializable formlets.}] + diff -Nru racket-7.2+ppa2/share/pkgs/web-server-doc/web-server/scribblings/http.scrbl racket-7.3+ppa1/share/pkgs/web-server-doc/web-server/scribblings/http.scrbl --- racket-7.2+ppa2/share/pkgs/web-server-doc/web-server/scribblings/http.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/web-server-doc/web-server/scribblings/http.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -169,13 +169,16 @@ @defmodule[web-server/http/response-structs]{ -@defstruct*[response - ([code number?] - [message bytes?] - [seconds number?] - [mime (or/c false/c bytes?)] - [headers (listof header?)] - [output (output-port? . -> . any)])]{ +@deftogether[ + (@defstruct*[response + ([code response-code/c] + [message bytes?] + [seconds real?] + [mime (or/c #f bytes?)] + [headers (listof header?)] + [output (output-port? . -> . any)])] + @defthing[response-code/c flat-contract? + #:value (integer-in 100 999)])]{ An HTTP response where @racket[output] produces the body by writing to the output port. @racket[code] is the response code, @racket[message] @@ -223,12 +226,18 @@ void) ] -@history[#:changed "1.2" - @elem{Contract on @racket[output] weaked to allow @racket[any] +@history[#:changed "1.3" + @elem{Added @racket[response-code/c] and made the + contracts on @racket[code] and @racket[seconds] + stronger (rather than accepting @racket[number?]).} + #:changed "1.2" + @elem{Contract on @racket[output] weakened to allow @racket[any] as the result (instead of demanding @racket[void?]).}] } -@defproc[(response/full [code number?] [message bytes?] [seconds number?] [mime (or/c false/c bytes?)] +@defproc[(response/full [code response-code/c] [message (or/c #f bytes?)] + [seconds real?] + [mime (or/c #f bytes?)] [headers (listof header?)] [body (listof bytes?)]) response?]{ A constructor for responses where @racket[body] is the response body. @@ -246,20 +255,77 @@ #"\">here instead." #"

")) ] + + If @racket[message] is not supplied or is @racket[#f], a status message will be inferred based on @racket[code]. Status messages will be inferred based on RFCs 7231 (``Hypertext Transfer Protocol (HTTP/1.1): Semantics and Content'') and 7235 (``Hypertext Transfer Protocol (HTTP/1.1): Authentication''). These are the following: + + @tabular[#:sep @hspace[1] + (list (list @bold{Code} @bold{Message}) + (list "100" "Continue") + (list "101" "Switching Protocols") + + (list "200" "OK") + (list "201" "Created") + (list "202" "Accepted") + (list "203" "Non-Authoritative Information") + (list "204" "No Content") + (list "205" "Reset Content") + + (list "300" "Multiple Choices") + (list "301" "Moved Permanently") + (list "302" "Found") + (list "303" "See Other") + (list "305" "Use Proxy") + (list "307" "Temporary Redirect") + + (list "400" "Bad Request") + (list "401" "Unauthorized") + (list "402" "Payment Required") + (list "403" "Forbidden") + (list "404" "Not Found") + (list "405" "Method Not Allowed") + (list "406" "Not Acceptable") + (list "407" "Proxy Authentication Required") + (list "408" "Request Timeout") + (list "409" "Conflict") + (list "410" "Gone") + (list "411" "Length Required") + (list "413" "Payload Too Large") + (list "414" "URI Too Long") + (list "415" "Unsupported Media Type") + (list "417" "Expectation Failed") + (list "426" "Upgrade Required") + + (list "500" "Internal Server Error") + (list "501" "Not Implemented") + (list "502" "Bad Gateway") + (list "503" "Service Unavailable") + (list "504" "Gateway Timeout") + (list "505" "HTTP Version Not Supported"))] + + @history[#:changed "1.3" + @elem{Updated contracts on @racket[code] and @racket[seconds] + as with @racket[response].}] + @history[#:changed "1.4" + @elem{Contract on @racket[message] relaxed to allow both @racket[#f] and a @racket[bytes?], with a default of @racket[#f]. Previously, @racket[bytes?] was required, and had a default of @racket[#"Okay"].}] } - + @defproc[(response/output [output (-> output-port? any)] [#:code code number? 200] - [#:message message bytes? #"Okay"] + [#:message message (or/c false/c bytes?) #f] [#:seconds seconds number? (current-seconds)] [#:mime-type mime-type (or/c bytes? #f) TEXT/HTML-MIME-TYPE] [#:headers headers (listof header?) '()]) response?]{ Equivalent to -@racketblock[(response code message seconds mime-type headers output)] +@racketblock[(response code message seconds mime-type headers output)], with the understanding that if @racket[message] is missing, it will be inferred from @racket[code] using the association between status codes and messages found in RFCs 7231 and 7235. See the documentation for @racket[response/full] for the table of built-in status codes. -@history[#:changed "1.2" - @elem{Contract on @racket[output] weaked to allow @racket[any] +@history[#:changed "1.4" + @elem{Contract on @racket[message] relaxed to allow both @racket[#f] and a @racket[bytes?], with a default of @racket[#f]. Previously, @racket[bytes?] was required, and had a default of @racket[#"Okay"].} + #:changed "1.3" + @elem{Updated contracts on @racket[code] and @racket[seconds] + as with @racket[response].} + #:changed "1.2" + @elem{Contract on @racket[output] weakened to allow @racket[any] as the result (instead of demanding @racket[void?]).}] } @@ -276,16 +342,20 @@ @(require (for-label (except-in net/cookies/server make-cookie) net/cookies/common - web-server/servlet + web-server/servlet web-server/http/xexpr web-server/http/redirect web-server/http/request-structs web-server/http/response-structs web-server/http/cookie)) +@(define rfc6265 + (hyperlink "https://tools.ietf.org/html/rfc6265.html" + "RFC 6265")) + @defmodule[web-server/http/cookie]{ This module provides functions to create cookies and responses that set them. - + @defproc[(make-cookie [name cookie-name?] [value cookie-value?] [#:comment comment any/c #f] @@ -300,11 +370,23 @@ Constructs a cookie with the appropriate fields. This is a wrapper around @racket[make-cookie] from @racketmodname[net/cookies/server] - for backwards compatability. The @racket[comment] argument is ignored. + for backwards compatibility. The @racket[comment] argument is ignored. If @racket[expires] is given as a string, it should match @link["https://tools.ietf.org/html/rfc7231#section-7.1.1.2"]{RFC 7231, Section 7.1.1.2}, in which case it will be converted to a @racket[date?] value. If conversion fails, an @racket[exn:fail:contract?] is raised. + + @history[ + #:changed "1.3" + @elem{Added support for @rfc6265 via @racketmodname[net/cookies/server]. + Enforce stronger contracts on string-valued arguments. + Allow @racket[expires] to be a @racket[date?] + and allow @racket[secure] to be @racket[any/c] + (rather than @racket[boolean?]). + Forbid @racket[0] for @racket[max-age]. + Support @racket[http-only?] and @racket[extension] arguments. + Ignore @racket[comment]. + }] } @defproc[(cookie->header [c cookie?]) header?]{ @@ -358,25 +440,24 @@ @racket[_authored-seconds] is not after a timeout period, and only then return the cookie data to the program. -The interface represents the secret key as a byte string. The best way -to generate this is by using random bytes from something like OpenSSL -or -@tt{/dev/random}. @link["http://www.madboa.com/geek/openssl/#random-generate"]{This -FAQ} lists a few options. A convenient purely Racket-based option is -available (@racket[make-secret-salt/file]), - which is implemented using @racket[crypto-random-bytes]. +The interface represents the secret key as a byte string. +@bold{For security, this should be created using cryptographic-quality randomness.} +A convenient purely Racket-based option is @racket[make-secret-salt/file], +which is implemented using @racket[crypto-random-bytes]. +You can also generate random bytes using something like OpenSSL or @tt{/dev/random}: + @link["https://www.madboa.com/geek/openssl/#random-data"]{this FAQ} lists a few options. @defproc*[([(make-id-cookie [name (and/c string? cookie-name?)] [value (and/c string? cookie-value?)] [#:key secret-salt bytes?] [#:path path (or/c path/extension-value? #f) #f] - [#:expires expires (or/c date? #f) #f] + [#:expires expires (or/c date? #f) #f] [#:max-age max-age - (or/c (and/c integer? positive?) #f) #f] - [#:domain domain (or/c domain-value? #f) #f] - [#:secure? secure? any/c #f] - [#:http-only? http-only? any/c #f] + (or/c (and/c integer? positive?) #f) #f] + [#:domain domain (or/c domain-value? #f) #f] + [#:secure? secure? any/c #f] + [#:http-only? http-only? any/c #f] [#:extension extension (or/c path/extension-value? #f) #f]) cookie?] @@ -385,12 +466,12 @@ [secret-salt bytes?] [value (and/c string? cookie-value?)] [#:path path (or/c path/extension-value? #f) #f] - [#:expires expires (or/c date? #f) #f] + [#:expires expires (or/c date? #f) #f] [#:max-age max-age - (or/c (and/c integer? positive?) #f) #f] - [#:domain domain (or/c domain-value? #f) #f] - [#:secure? secure? any/c #f] - [#:http-only? http-only? any/c #t] + (or/c (and/c integer? positive?) #f) #f] + [#:domain domain (or/c domain-value? #f) #f] + [#:secure? secure? any/c #f] + [#:http-only? http-only? any/c #t] [#:extension extension (or/c path/extension-value? #f) #f]) cookie?])]{ @@ -398,11 +479,22 @@ The calling conventions allow @racket[secret-salt] to be given either as a keyword argument (mirroring the style of @racket[make-cookie]) or a by-position argument - (for compatability with older versions of this library). + (for compatibility with older versions of this library). The other arguments are passed to @racket[make-cookie]; however, note that the default value for @racket[http-only?] is @racket[#t]. Users will also likely want to set @racket[secure?] to @racket[#t] when using HTTPS. + + @history[ + #:changed "1.3" + @elem{Added support for @rfc6265 as with @racket[make-cookie], + including adding the optional arguments + @racket[expires], @racket[max-age], @racket[domain], + @racket[secure], @racket[extension], + and @racket[http-only?] (which is @racket[#true] by default). + Allowed @racket[secret-salt] to be given with the keyword + @racket[#:key] instead of by position. + }] } @defproc*[([(request-id-cookie [request request?] @@ -422,8 +514,14 @@ from @racket[request], with the allowable age of the cookie is controlled by @racket[shelf-life] and @racket[timeout] as with @racket[valid-id-cookie?]. - + If no valid cookie is available, returns @racket[#f]. + + @history[#:changed "1.3" + @elem{Added @racket[shelf-life] argument and + support for giving @racket[name] and @racket[secret-salt] + by keyword instead of by position. + Added support for @rfc6265 as with @racket[make-cookie].}] } @defproc[(valid-id-cookie? [cookie any/c] @@ -453,8 +551,10 @@ value returned by @racket[(current-seconds)] when the cookie was created. The default value, @racket[+inf.0], permits all properly named and signed cookies. + + @history[#:added "1.3"] } - + @defproc[(logout-id-cookie [name cookie-name?] [#:path path (or/c #f string?) #f] [#:domain domain (or/c domain-value? #f) #f]) @@ -464,7 +564,7 @@ This will cause non-malicious browsers to overwrite a previously set cookie. If you use authenticated cookies for login information, you - could send this to cause a "logout". However, malicious browsers do + could send this to cause a ``logout.'' However, malicious browsers do not need to respect such an overwrite. Therefore, this is not an effective way to implement timeouts or protect users on public (i.e. possibly compromised) computers. The only way to securely @@ -472,14 +572,23 @@ keeping track of which cookies (sessions, etc.) are invalid. Depending on your application, it may be better to track live sessions or dead sessions, or never set cookies to begin with and just use - continuations, which you can revoke with @racket[send/finish]. + (stateful) continuations, which you can revoke with @racket[send/finish]. + + @history[#:changed "1.3" + @elem{Added support for @rfc6265 as with @racket[make-cookie], + including adding the @racket[domain] argument.}] } @defproc[(make-secret-salt/file [secret-salt-path path-string?]) bytes?]{ Extracts the bytes from @racket[secret-salt-path]. If @racket[secret-salt-path] does not exist, then it is created and - initialized with 128 random bytes. + initialized with 128 cryptographic-quality random bytes + from @racket[crypto-random-bytes]. + + @history[#:changed "1.3" + @elem{Changed to use cryptographic-quality randomness + to initialize @racket[secret-salt-path].}] } } @@ -505,6 +614,10 @@ @defproc[(request-cookies [req request?]) (listof client-cookie?)]{ Extracts the cookies from @racket[req]'s headers. + + @history[#:changed "1.3" + @elem{Added support for @rfc6265 via + @racketmodname[net/cookies/client].}] } Examples: @@ -541,28 +654,97 @@ @defmodule[web-server/http/redirect]{ -@defproc[(redirect-to [uri non-empty-string?] - [perm/temp redirection-status? temporarily] - [#:headers headers (listof header?) (list)]) - response?]{ - Generates an HTTP response that redirects the browser to @racket[uri], - while including the @racket[headers] in the response. - - Example: - @racket[(redirect-to "http://www.add-three-numbers.com" permanently)] -} - -@defproc[(redirection-status? [v any/c]) - boolean?]{ - Determines if @racket[v] is one of the following values. -} - -@defthing[permanently redirection-status?]{A @racket[redirection-status?] for permanent redirections.} +@deftogether[ + (@defproc[(redirect-to [uri non-empty-string?] + [status redirection-status? temporarily] + [#:headers headers (listof header?) '()]) + response?] + @defproc[(redirection-status? [v any/c]) boolean?] + @defthing[temporarily redirection-status?] + @defthing[temporarily/same-method redirection-status?] + @defthing[see-other redirection-status?] + @defthing[permanently redirection-status?])]{ + The function @racket[redirect-to] + generates an HTTP response that redirects the browser to @racket[uri], + while including the @racket[headers] in the response. + The @racket[status] argument is a @deftech{redirection status} + value, which determines the specific type of HTTP redirect to be used. + + The default @tech{redirection status}, @racket[temporarily], + is preserved for backwards compatibility: + new code should usually use either @racket[temporarily/same-method] + or @racket[see-other], instead. + The @racket[temporarily] @tech{redirection status} corresponds to + @hyperlink["https://tools.ietf.org/html/rfc7231#section-6.4.3"]{ + @litchar{302 Found}}. + Unfortunately, browsers have not implemented this status consistently + for methods other than @litchar{GET} and (in practice, with all but some + very old browsers) @litchar{POST}. + + The @racket[temporarily/same-method] @tech{redirection status} + uses @hyperlink["https://tools.ietf.org/html/rfc7231#section-6.4.7"]{ + @litchar{307 Temporary Redirect}}. + This redirects the browser to @racket[uri] using the same HTTP method + as the original request. + + The @racket[see-other] @tech{redirection status} corresponds to + @hyperlink["https://tools.ietf.org/html/rfc7231#section-6.4.4"]{ + @litchar{303 See Other}}. + It is most often used to implement the @deftech{Post-Redirect-Get} + pattern: as a response to a request using @litchar{POST} or + another HTTP method with side-effects, it causes the browser to + perform a @litchar{GET} or @litchar{HEAD} request for @racket[uri], + which gives a response to the original @litchar{POST} request. + This prevents the @onscreen{Back} and @onscreen{Refresh} buttons + from duplicating effects, such as making a purchase or + adding items to a database. + The web server provides @racket[redirect/get] for added convenience + with @tech{Post-Redirect-Get}. + + The @racket[permanently] @tech{redirection status} uses the HTTP status + @hyperlink["https://tools.ietf.org/html/rfc7231#section-6.4.2"]{ + @litchar{301 Moved Permanently}}. + It is like @racket[temporarily], except that, as the name suggests, + it signifies that the move is permanent and that search engines, + for example, should use @racket[uri] instead of the URI of the + original request. + Unfortunately, @racket[permanently] is also like @racket[temporarily] + in that browsers have implemented it inconsistently for + methods other than @litchar{GET} and @litchar{HEAD}: + in particular, @hyperlink["https://tools.ietf.org/html/rfc7231#section-6.4.2"]{ + RFC 7231} permits that, ``for historical reasons, a user agent @bold{may} + change the request method from @litchar{POST} to @litchar{GET} for the subsequent request. + When it is important to ensure that the request to @racket[uri] use the same method, + there are some possible alternatives: + @itemlist[ + @item{RFC 7231 suggests using @litchar{307 Temporary Redirect}, + i.e. @racket[temporarily/same-method]. + This has the disadvantage that search engines and others won't + update references to the old URI.} + @item{@hyperlink["https://tools.ietf.org/html/rfc7538"]{RFC 7538} + specifies a new HTTP status, @litchar{308 Permanent Redirect}, + which forbids changing the request method, analogously to + @litchar{307 Temporary Redirect}. + However, the RFC also highlights some important + @hyperlink["https://tools.ietf.org/html/rfc7538#section-4"]{ + deployment considerations} for this status. + In particular, older browsers---including, as of this writing, + some that remain in + @hyperlink["https://developer.mozilla.org/en-US/docs/Web/HTTP/Status/308#Browser_compatibility"]{ + relatively common use}---do not understand this status and will + fall back to the semantics of + @hyperlink["https://tools.ietf.org/html/rfc7231#section-6.4.1"]{ + @litchar{300 Multiple Choices}}, which is often undesirable.} + @item{The application can note the method of the original request + and use @racket[permanently] for @litchar{GET} and @litchar{HEAD} requests + or one of the other alternatives for other methods.}] -@defthing[temporarily redirection-status?]{A @racket[redirection-status?] for temporary redirections.} - -@defthing[see-other redirection-status?]{A @racket[redirection-status?] for "see-other" redirections.} + Example: + @racket[(redirect-to "http://www.add-three-numbers.com" permanently)] + } + @history[#:changed "1.3" + @elem{Added @racket[temporarily/same-method].}] } @; ------------------------------------------------------------ @@ -700,10 +882,10 @@ @declare-exporting[web-server/http/xexpr web-server] @defproc[(response/xexpr [xexpr xexpr/c] - [#:code code number? 200] - [#:message message bytes? #"Okay"] - [#:seconds seconds number? (current-seconds)] - [#:mime-type mime-type (or/c false/c bytes?) TEXT/HTML-MIME-TYPE] + [#:code code response-code/c 200] + [#:message message (or/c #f bytes?) #f] + [#:seconds seconds real? (current-seconds)] + [#:mime-type mime-type (or/c #f bytes?) TEXT/HTML-MIME-TYPE] [#:headers headers (listof header?) empty] [#:cookies cookies (listof cookie?) empty] [#:preamble preamble bytes? #""]) @@ -717,4 +899,12 @@ ] This is a viable function to pass to @racket[set-any->response!]. - } + + See the documentation for @racket[response/full] to see how @racket[#f] is handled for @racket[message]. + +@history[#:changed "1.4" + @elem{Contract on @racket[message] relaxed to allow both @racket[#f] and @racket[bytes?], with a default of @racket[#f]. Previously, @racket[bytes?] was required, and had a default of @racket[#"Okay"].} + #:changed "1.3" + @elem{Updated contracts on @racket[code] and @racket[seconds] + as with @racket[response].}] +} diff -Nru racket-7.2+ppa2/share/pkgs/web-server-doc/web-server/scribblings/lang.scrbl racket-7.3+ppa1/share/pkgs/web-server-doc/web-server/scribblings/lang.scrbl --- racket-7.2+ppa2/share/pkgs/web-server-doc/web-server/scribblings/lang.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/web-server-doc/web-server/scribblings/lang.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -47,9 +47,12 @@ Like @racket[send/suspend/url/dispatch] but with a string URL representation. } -@deftogether[( -@defproc[(redirect/get) request?] -)]{ -See @racketmodname[web-server/servlet/web].} +@defproc[(redirect/get [#:headers hs (listof header?) empty]) request?]{ +See @racketmodname[web-server/servlet/web]. + + @history[#:changed "1.3" + @elem{Added @racket[hs] argument and + changed to use @racket[see-other] instead of @racket[temporarily].}] + } } diff -Nru racket-7.2+ppa2/share/pkgs/web-server-doc/web-server/scribblings/running.scrbl racket-7.3+ppa1/share/pkgs/web-server-doc/web-server/scribblings/running.scrbl --- racket-7.2+ppa2/share/pkgs/web-server-doc/web-server/scribblings/running.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/web-server-doc/web-server/scribblings/running.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -41,7 +41,7 @@ } @defproc[(static-files-path [path path-string?]) void]{ - This instructs the Web server to serve static files, such as stylesheet and images, from @racket[path]. + This instructs the Web server to serve static files, such as stylesheets and images, from @racket[path]. } If you want more control over specific parameters, keep reading about @racketmodname[web-server/servlet-env]. @@ -63,12 +63,12 @@ @commandline{plt-web-server [-f -p -a --ssl]} -The optional file-name argument specifies the path to a +The optional @tt{file-name} argument specifies the path to a @racket[configuration-table] S-expression (see @racket[configuration-table->sexpr] for the syntax documentation.) If this is not provided, the default configuration shipped with the server is used. The optional -port and ip-address arguments override the corresponding portions of -the @racket[configuration-table]. If the SSL option is provided, then +@tt{port} and @tt{ip-address} arguments override the corresponding portions of +the @racket[configuration-table]. If the @tt{ssl} option is provided, then the server uses HTTPS with @filepath{server-cert.pem} and @filepath{private-key.pem} in the current directory, with 443 as the default port. (See the @racketmodname[openssl] module for details on the SSL implementation.) diff -Nru racket-7.2+ppa2/share/pkgs/web-server-doc/web-server/scribblings/servlet-env.scrbl racket-7.3+ppa1/share/pkgs/web-server-doc/web-server/scribblings/servlet-env.scrbl --- racket-7.2+ppa2/share/pkgs/web-server-doc/web-server/scribblings/servlet-env.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/web-server-doc/web-server/scribblings/servlet-env.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -240,4 +240,7 @@ 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. + + @history[#:changed "1.3" + @elem{Added support for providing @racket[log-file] as an output port.}] } diff -Nru racket-7.2+ppa2/share/pkgs/web-server-doc/web-server/scribblings/templates.scrbl racket-7.3+ppa1/share/pkgs/web-server-doc/web-server/scribblings/templates.scrbl --- racket-7.2+ppa2/share/pkgs/web-server-doc/web-server/scribblings/templates.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/web-server-doc/web-server/scribblings/templates.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -163,7 +163,9 @@ } ] -@section{Gotchas: @"@" Syntax: @"@" character, identifiers, and spaces} +@section{Gotchas:} +@subsection[#:tag "Gotchas____Syntax____character__identifiers__and_spaces"]{ + @"@" Syntax: @"@" character, identifiers, and spaces} To obtain an @litchar["@"] character in template output, you must escape the it, because it is the escape character of the @@ -199,7 +201,7 @@ If you intend to use templates a lot, you should familiarize yourself with the details of the @|at-reader-ref|. -@section{Gotchas: Iteration} +@subsection[#:tag "Gotchas__Iteration"]{Iteration} Since the template is compiled into a Racket program, only its results will be printed. For example, suppose we have the template: @@ -267,7 +269,7 @@ }| Notice how it also avoids the absurd amount of punctuation on line two. -@section{Escaping} +@subsection{Escaping} @margin-note{Thanks to Michael W. for this section.} @@ -381,7 +383,10 @@ @defform*[((include-template/xml path-spec) (include-template/xml #:command-char command-char path-spec))]{ - Like @racket[include/template], but expands to a @racket[cdata] structure.} + Like @racket[include/template], but expands to a @racket[cdata] structure. + +@history[#:added "1.3"] +} @defform[(in x xs e ...)]{ Expands into diff -Nru racket-7.2+ppa2/share/pkgs/web-server-doc/web-server/scribblings/tutorial/continue.scrbl racket-7.3+ppa1/share/pkgs/web-server-doc/web-server/scribblings/tutorial/continue.scrbl --- racket-7.2+ppa2/share/pkgs/web-server-doc/web-server/scribblings/tutorial/continue.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/web-server-doc/web-server/scribblings/tutorial/continue.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -73,10 +73,14 @@ @(defstruct* post ([title string?] [body string?])) +@linebreak[] + @bold{Exercise.} Make a few examples of posts. Next we define a blog to be simply a list of posts: +@linebreak[] + @(defthing blog (listof post?)) Here, then, is a very simple example of a blog: @@ -195,6 +199,8 @@ @defthing[render-post (post? . -> . xexpr/c)] +@linebreak[] + As an example, we want: @racketblock[ @@ -253,6 +259,8 @@ @defthing[render-posts ((listof post?) . -> . xexpr/c)] +@linebreak[] + As examples, @racketblock[ @@ -311,17 +319,23 @@ @defthing[request-bindings (request? . -> . bindings?)] +@linebreak[] + To extract a single web form value from a set of bindings, Racket provides the function @racket[extract-binding/single], which also takes the name of the corresponding field of the web form: @defthing[extract-binding/single (symbol? bindings? . -> . string?)] +@linebreak[] + To verify that a set of bindings contains a particular field, use @racket[exists-binding?]: @defthing[exists-binding? (symbol? bindings? . -> . boolean?)] +@linebreak[] + With these functions, we can design functions that consume @racket[request]s and respond to them usefully. @@ -332,6 +346,8 @@ @defthing[can-parse-post? (bindings? . -> . boolean?)] +@linebreak[] + @bold{Exercise.} Write a function @racket[parse-post] that consumes a set of bindings. Assuming that the bindings structure has values for the symbols @racket['title] @@ -340,6 +356,8 @@ @defthing[parse-post (bindings? . -> . post?)] +@linebreak[] + Now that we have these helper functions, we can extend our web application to handle form input. We'll add a small form at the bottom of the web page, and we'll adjust our program to handle the addition of new posts. @@ -497,7 +515,7 @@ @defthing[set-blog-posts! (blog? (listof post?) . -> . void)] - +@linebreak[] @bold{Exercise.} Write a function @racket[blog-insert-post!] @@ -719,6 +737,8 @@ @defthing[redirect/get (-> request?)] +@linebreak[] + Its immediate side effect is to force the user's browser to follow a redirection to a safe URL, and it gives us back that fresh new request. @@ -912,6 +932,8 @@ @defthing[blog-insert-post! (blog? string? string? . -> . void)] @defthing[post-insert-comment! (blog? post? string? . -> . void)] +@linebreak[] + @bold{Exercise.} Write the new definitions of @racket[blog-insert-post!] and @racket[post-insert-comment!]. Remember to call @racket[save-blog!]. @@ -1026,6 +1048,8 @@ @defstruct*[blog ([db connection?])] +@linebreak[] + @bold{Exercise.} Write the @racket[blog] structure definition. It does not need to be mutable or serializable. @@ -1113,6 +1137,8 @@ @defstruct*[post ([blog blog?] [id integer?])] +@linebreak[] + @bold{Exercise.} Write the structure definition for posts. The only function that creates posts is @racket[blog-posts]: diff -Nru racket-7.2+ppa2/share/pkgs/web-server-doc/web-server/scribblings/web.scrbl racket-7.3+ppa1/share/pkgs/web-server-doc/web-server/scribblings/web.scrbl --- racket-7.2+ppa2/share/pkgs/web-server-doc/web-server/scribblings/web.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/web-server-doc/web-server/scribblings/web.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -152,15 +152,26 @@ @defproc[(redirect/get [#:headers hs (listof header?) empty]) request?]{ - Calls @racket[send/suspend] with @racket[redirect-to], passing @racket[hs] as the headers. + Calls @racket[send/suspend] with @racket[redirect-to], + passing @racket[hs] as the headers and + @racket[see-other] as the @tech{redirection status}. - This implements the Post-Redirect-Get pattern. - Use this to prevent the @onscreen["Refresh"] button from duplicating effects, such as adding items to a database. + This implements the @tech{Post-Redirect-Get} pattern. + Use this to prevent the @onscreen["Refresh"] button from duplicating effects, + such as adding items to a database. + + @history[#:changed "1.3" + @elem{Use @racket[see-other] instead of @racket[temporarily].}] } @defproc[(redirect/get/forget [#:headers hs (listof header?) empty]) request?]{ - Calls @racket[send/forward] with @racket[redirect-to], passing @racket[hs] as the headers. + Like @racket[redirect/get], but using @racket[send/forward] + instead of @racket[send/suspend]. + + @history[#:changed "1.3" + @elem{Use @racket[see-other] instead of @racket[temporarily], + as with @racket[redirect/get].}] } @defthing[current-servlet-continuation-expiration-handler diff -Nru racket-7.2+ppa2/share/pkgs/web-server-doc/web-server/scribblings/web-server.scrbl racket-7.3+ppa1/share/pkgs/web-server-doc/web-server/scribblings/web-server.scrbl --- racket-7.2+ppa2/share/pkgs/web-server-doc/web-server/scribblings/web-server.scrbl 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/web-server-doc/web-server/scribblings/web-server.scrbl 2019-05-16 01:29:07.000000000 +0000 @@ -11,7 +11,7 @@ @secref["servlet"] and @secref["stateless"] describe two ways to write Web applications. @secref["servlet"] use the entire Racket language, but their continuations are stored in the Web server's memory. -@secref["stateless"] use a slightly restricted Racket language, but their continuation can be stored by the Web client or on a Web server's disk. If you can, you want to use @secref["stateless"] for the improved scalability. +@secref["stateless"] use a slightly restricted Racket language, but their continuations can be stored by the Web client or on a Web server's disk. If you can, you want to use @secref["stateless"] for the improved scalability. The @secref["http"] section describes the common library functions for manipulating HTTP requests and creating HTTP responses. In particular, this section covers cookies, authentication, and request bindings. diff -Nru racket-7.2+ppa2/share/pkgs/web-server-lib/info.rkt racket-7.3+ppa1/share/pkgs/web-server-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/web-server-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/web-server-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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.4"))) diff -Nru racket-7.2+ppa2/share/pkgs/web-server-lib/web-server/dispatch/syntax.rkt racket-7.3+ppa1/share/pkgs/web-server-lib/web-server/dispatch/syntax.rkt --- racket-7.2+ppa2/share/pkgs/web-server-lib/web-server/dispatch/syntax.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/web-server-lib/web-server/dispatch/syntax.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -10,6 +10,9 @@ syntax/parse web-server/dispatch/pattern)) +(module+ test + (require rackunit)) + (define (default-else req) (next-dispatcher)) @@ -25,6 +28,22 @@ strlist)) empty #f))) +(module+ test + (check-equal? (string-list->url (list)) + "/") + (check-equal? (string-list->url (list "foo")) + "/foo") + (check-equal? (string-list->url (list "")) + "/") + (check-equal? (string-list->url (list "" "")) + "//") + (check-equal? (string-list->url (list "" "gonzo")) + "//gonzo") + (check-equal? (string-list->url (list "gonzo" "")) + "/gonzo/") + (check-equal? (string-list->url (list "baked" "beans")) + "/baked/beans")) + (define-syntax (dispatch-case stx) (syntax-parse stx #:literals (else) diff -Nru racket-7.2+ppa2/share/pkgs/web-server-lib/web-server/http/redirect.rkt racket-7.3+ppa1/share/pkgs/web-server-lib/web-server/http/redirect.rkt --- racket-7.2+ppa2/share/pkgs/web-server-lib/web-server/http/redirect.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/web-server-lib/web-server/http/redirect.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1,16 +1,22 @@ #lang racket/base (require racket/contract (only-in racket/string non-empty-string?) - web-server/private/util web-server/http/response-structs web-server/http/request-structs) -; redirection-status = (make-redirection-status nat bytes) -(define-struct redirection-status (code message)) +; redirection-status = (redirection-status nat bytes) +(struct redirection-status (code message)) -(define permanently (make-redirection-status 301 #"Moved Permanently")) -(define temporarily (make-redirection-status 302 #"Moved Temporarily")) -(define see-other (make-redirection-status 303 #"See Other")) +(define permanently + ;; NOTE: 308 permanent redirect is not supported by + ;; Internet Explorer on Windows 7 or 8.1 as of 2019-02-26. + ;; (IE on Windows 10 does support it.) + ;; https://developer.mozilla.org/en-US/docs/Web/HTTP/Status/308 + ;; https://tools.ietf.org/html/rfc7538#section-4 + (redirection-status 301 #"Moved Permanently")) +(define temporarily (redirection-status 302 #"Found")) +(define temporarily/same-method (redirection-status 307 #"Temporary Redirect")) +(define see-other (redirection-status 303 #"See Other")) ; : str [redirection-status] -> response (define (redirect-to @@ -19,7 +25,7 @@ #:headers [headers (list)]) (response (redirection-status-code perm/temp) (redirection-status-message perm/temp) - (current-seconds) #"text/html" + (current-seconds) #f (list* (make-header #"Location" (string->bytes/utf-8 uri)) headers) void)) @@ -31,4 +37,5 @@ [redirection-status? (any/c . -> . boolean?)] [permanently redirection-status?] [temporarily redirection-status?] + [temporarily/same-method redirection-status?] [see-other redirection-status?]) diff -Nru racket-7.2+ppa2/share/pkgs/web-server-lib/web-server/http/response-structs.rkt racket-7.3+ppa1/share/pkgs/web-server-lib/web-server/http/response-structs.rkt --- racket-7.2+ppa2/share/pkgs/web-server-lib/web-server/http/response-structs.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/web-server-lib/web-server/http/response-structs.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1,14 +1,22 @@ #lang racket/base -(require racket/contract - web-server/http/request-structs) +(require racket/contract + racket/match + web-server/http/request-structs + "status-code.rkt") + +(module+ test + (require rackunit)) (define TEXT/HTML-MIME-TYPE #"text/html; charset=utf-8") (struct response (code message seconds mime headers output)) (define (response/full code message seconds mime headers body) - (response code message seconds mime - (list* (make-header #"Content-Length" + (response code + (infer-response-message code message) + seconds + mime + (list* (make-header #"Content-Length" (string->bytes/utf-8 (number->string (for/fold ([len 0]) @@ -21,27 +29,67 @@ (define (response/output output #:code [code 200] - #:message [message #"Okay"] + #:message [message #f] #:seconds [seconds (current-seconds)] #:mime-type [mime-type TEXT/HTML-MIME-TYPE] #:headers [headers '()]) - (response code message seconds mime-type headers + (response code + (infer-response-message code message) + seconds + mime-type + headers output)) +(module+ test + (let ([output (lambda (op) void)]) + ;; check message as bytes + (let [(resp (response/output output + #:code 123 + #:message #"bites!"))] + (check-equal? (response-code resp) 123) + (check-equal? (response-message resp) #"bites!")) + ;; check message as #f + (let [(resp (response/output output + #:code 200 + #:message #f))] + (check-equal? (response-code resp) 200) + (check-equal? (response-message resp) #"OK")) + ;; check message not supplied, but code supplied + (let [(resp (response/output output + #:code 200))] + (check-equal? (response-code resp) 200) + (check-equal? (response-message resp) #"OK")) + ;; check code not supplied, message supplied + (let [(resp (response/output output + #:message #"bite this"))] + (check-equal? (response-code resp) 200) + (check-equal? (response-message resp) #"bite this")) + ;; check neither message nor code supplied + (let [(resp (response/output output))] + (check-equal? (response-code resp) 200) + (check-equal? (response-message resp) #"OK")) + ;; check non-standard status code + (let [(resp (response/output output #:code 123))] + (check-equal? (response-code resp) 123) + (check-equal? (response-message resp) #"OK")))) + +(define/final-prop response-code/c + (integer-in 100 999)) +(provide response-code/c) (provide/contract [struct response - ([code number?] + ([code response-code/c] [message bytes?] - [seconds number?] - [mime (or/c false/c bytes?)] + [seconds real?] + [mime (or/c #f bytes?)] [headers (listof header?)] [output (output-port? . -> . any)])] - [response/full (-> number? bytes? number? (or/c false/c bytes?) (listof header?) (listof bytes?) response?)] + [response/full (-> response-code/c (or/c #f bytes?) real? (or/c #f bytes?) (listof header?) (listof bytes?) response?)] [response/output (->* ((-> output-port? any)) - (#:code number? + (#:code response-code/c #:message bytes? - #:seconds number? + #:seconds real? #:mime-type (or/c bytes? #f) #:headers (listof header?)) response?)] diff -Nru racket-7.2+ppa2/share/pkgs/web-server-lib/web-server/http/status-code.rkt racket-7.3+ppa1/share/pkgs/web-server-lib/web-server/http/status-code.rkt --- racket-7.2+ppa2/share/pkgs/web-server-lib/web-server/http/status-code.rkt 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/web-server-lib/web-server/http/status-code.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,96 @@ +#lang racket/base + +(require racket/contract + racket/match + (only-in racket/string + non-empty-string?)) + +(provide/contract + [message-for-status-code + (number? . -> . (or/c false/c non-empty-string?))] + [DEFAULT-STATUS-MESSAGE + bytes?] + [infer-response-message + (number? (or/c false/c bytes?) . -> . bytes?)]) + +(module+ test + (require rackunit)) + +;; HTTP status codes coming from +;; +;; + Hypertext Transfer Protocol (HTTP/1.1): Semantics and Content +;; (https://tools.ietf.org/html/rfc7231) +;; +;; + Hypertext Transfer Protocol (HTTP/1.1): Authentication +;; (https://tools.ietf.org/html/rfc7235) + +(define/contract common-http-status-codes&messages + (and/c (hash/c (integer-in 100 599) non-empty-string?) + immutable?) + (hasheq + 100 "Continue" + 101 "Switching Protocols" + + 200 "OK" + 201 "Created" + 202 "Accepted" + 203 "Non-Authoritative Information" + 204 "No Content" + 205 "Reset Content" + + 300 "Multiple Choices" + 301 "Moved Permanently" + 302 "Found" + 303 "See Other" + 305 "Use Proxy" + 307 "Temporary Redirect" + + 400 "Bad Request" + 401 "Unauthorized" + 402 "Payment Required" + 403 "Forbidden" + 404 "Not Found" + 405 "Method Not Allowed" + 406 "Not Acceptable" + 407 "Proxy Authentication Required" + 408 "Request Timeout" + 409 "Conflict" + 410 "Gone" + 411 "Length Required" + 413 "Payload Too Large" + 414 "URI Too Long" + 415 "Unsupported Media Type" + 417 "Expectation Failed" + 426 "Upgrade Required" + + 500 "Internal Server Error" + 501 "Not Implemented" + 502 "Bad Gateway" + 503 "Service Unavailable" + 504 "Gateway Timeout" + 505 "HTTP Version Not Supported")) + +(module+ test + (check-equal? + (list 100 101 + 200 201 202 203 204 205 + 300 301 302 303 305 307 + 400 401 402 403 404 405 406 407 408 409 410 411 413 414 415 417 426 + 500 501 502 503 504 505) + (sort (hash-keys common-http-status-codes&messages) <))) + +(define (message-for-status-code code) + (hash-ref common-http-status-codes&messages code #f)) + +(define DEFAULT-STATUS-MESSAGE #"OK") + +(define (infer-response-message code message) + (match message + [(? bytes?) + message] + [else + (match (message-for-status-code code) + [(? string? s) + (string->bytes/utf-8 s)] + [else + DEFAULT-STATUS-MESSAGE])])) diff -Nru racket-7.2+ppa2/share/pkgs/web-server-lib/web-server/http/xexpr.rkt racket-7.3+ppa1/share/pkgs/web-server-lib/web-server/http/xexpr.rkt --- racket-7.2+ppa2/share/pkgs/web-server-lib/web-server/http/xexpr.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/web-server-lib/web-server/http/xexpr.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1,33 +1,70 @@ #lang racket/base (require racket/contract racket/list + racket/match xml web-server/private/xexpr (except-in net/cookies/server make-cookie) "request-structs.rkt" "cookie.rkt" - "response-structs.rkt") + "response-structs.rkt" + "status-code.rkt") + +(module+ test + (require rackunit)) (define (response/xexpr xexpr - #:code [code 200] - #:message [message #"Okay"] + #:code [code 200] + #:message [message #f] #:seconds [seconds (current-seconds)] #:mime-type [mime-type TEXT/HTML-MIME-TYPE] #:cookies [cooks empty] #:headers [hdrs empty] #:preamble [preamble #""]) (response - code message seconds mime-type + code (infer-response-message code message) seconds mime-type ; rfc2109 also recommends some cache-control stuff here for cookies (append hdrs (map cookie->header cooks)) (λ (out) (write-bytes preamble out) (write-xexpr xexpr out)))) +(module+ test + ;; sanity check: we get a response + (check-true (response? (response/xexpr '(foo)))) + (let ([resp (response/xexpr '(html))]) + ;; no code, no message ==> 200 "OK" + (check-equal? 200 (response-code resp)) + (check-equal? #"OK" (response-message resp))) + ;; code present, message absent + (let ([resp (response/xexpr '(html) #:code 201)]) + (check-equal? 201 (response-code resp)) + (check-equal? #"Created" (response-message resp))) + ;; unknown status code used, no message + (let ([resp (response/xexpr '(html) #:code 256)]) + (check-equal? 256 (response-code resp)) + (check-equal? #"OK" (response-message resp))) + ;; known code used, #f used as message + (let ([resp (response/xexpr '(html) #:code 204 #:message #f)]) + (check-equal? 204 (response-code resp)) + (check-equal? #"No Content" (response-message resp))) + ;; known code used, message lookup overridden + (let ([resp (response/xexpr '(html) #:code 204 #:message #"Cowabunga")]) + (check-equal? 204 (response-code resp)) + (check-equal? #"Cowabunga" (response-message resp))) + ;; code absent, message #f ==> 200 "OK" + (let ([resp (response/xexpr '(html) #:message #f)]) + (check-equal? 200 (response-code resp)) + (check-equal? #"OK" (response-message resp))) + ;; code absent, message present ==> 200 + (let ([resp (response/xexpr '(html) #:message #"Say Cheese")]) + (check-equal? 200 (response-code resp)) + (check-equal? #"Say Cheese" (response-message resp)))) + (provide/contract - [response/xexpr + [response/xexpr ((pretty-xexpr/c) - (#:code number? #:message bytes? #:seconds number? #:mime-type (or/c false/c bytes?) #:cookies (listof cookie?) #:headers (listof header?) #:preamble bytes?) + (#:code response-code/c #:message (or/c #f bytes?) #:seconds real? #:mime-type (or/c #f bytes?) #:cookies (listof cookie?) #:headers (listof header?) #:preamble bytes?) . ->* . response?)]) diff -Nru racket-7.2+ppa2/share/pkgs/web-server-lib/web-server/lang/web.rkt racket-7.3+ppa1/share/pkgs/web-server-lib/web-server/lang/web.rkt --- racket-7.2+ppa2/share/pkgs/web-server-lib/web-server/lang/web.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/web-server-lib/web-server/lang/web.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -44,7 +44,7 @@ [send/suspend/url ((url? . -> . can-be-response?) . -> . request?)] [send/suspend/url/dispatch ((((request? . -> . any/c) . -> . url?) . -> . can-be-response?) . -> . any/c)] - [redirect/get (-> request?)]) + [redirect/get (->* () (#:headers (listof header?)) request?)]) ;; initial-servlet : (request -> response) -> (request -> can-be-response?) (define (initialize-servlet start) @@ -122,5 +122,7 @@ (read (open-input-bytes kont)))] [_ #f]))) -(define (redirect/get) - (send/suspend/url (lambda (k-url) (redirect-to (url->string k-url) temporarily)))) +(define (redirect/get #:headers [hs null]) + (send/suspend/url + (lambda (k-url) + (redirect-to (url->string k-url) see-other #:headers hs)))) diff -Nru racket-7.2+ppa2/share/pkgs/web-server-lib/web-server/servlet/web.rkt racket-7.3+ppa1/share/pkgs/web-server-lib/web-server/servlet/web.rkt --- racket-7.2+ppa2/share/pkgs/web-server-lib/web-server/servlet/web.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/web-server-lib/web-server/servlet/web.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1,6 +1,5 @@ #lang racket/base (require racket/contract - racket/list net/url) (require web-server/managers/manager web-server/private/util @@ -145,8 +144,8 @@ ;; ************************************************************ ;; HIGHER-LEVEL EXPORTS -(define ((make-redirect/get send/suspend) #:headers [hs empty]) - (send/suspend (lambda (k-url) (redirect-to k-url temporarily #:headers hs)))) +(define ((make-redirect/get send/suspend) #:headers [hs null]) + (send/suspend (lambda (k-url) (redirect-to k-url see-other #:headers hs)))) ; redirect/get : -> request (define redirect/get (make-redirect/get send/suspend)) diff -Nru racket-7.2+ppa2/share/pkgs/wxme/info.rkt racket-7.3+ppa1/share/pkgs/wxme/info.rkt --- racket-7.2+ppa2/share/pkgs/wxme/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/wxme/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/wxme-lib/info.rkt racket-7.3+ppa1/share/pkgs/wxme-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/wxme-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/wxme-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/xrepl/info.rkt racket-7.3+ppa1/share/pkgs/xrepl/info.rkt --- racket-7.2+ppa2/share/pkgs/xrepl/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/xrepl/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/xrepl-doc/info.rkt racket-7.3+ppa1/share/pkgs/xrepl-doc/info.rkt --- racket-7.2+ppa2/share/pkgs/xrepl-doc/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/xrepl-doc/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/xrepl-lib/info.rkt racket-7.3+ppa1/share/pkgs/xrepl-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/xrepl-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/xrepl-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/share/pkgs/zo-lib/compiler/zo-marshal.rkt racket-7.3+ppa1/share/pkgs/zo-lib/compiler/zo-marshal.rkt --- racket-7.2+ppa2/share/pkgs/zo-lib/compiler/zo-marshal.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/zo-lib/compiler/zo-marshal.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -12,7 +12,8 @@ racket/path racket/set racket/extflonum - racket/private/truncate-path) + racket/private/truncate-path + racket/fasl) (provide/contract [zo-marshal ((or/c linkl-directory? linkl-bundle?) . -> . bytes?)] @@ -45,7 +46,9 @@ (define version-bs (string->bytes/latin-1 (version))) (write-bytes (bytes (bytes-length version-bs)) outp) (write-bytes version-bs outp) - (define vm-bs #"racket") + (define vm-bs (or (for/or ([(name bundle) (in-hash top)]) + (hash-ref (linkl-bundle-table bundle) 'vm #f)) + #"racket")) (write-bytes (bytes (bytes-length vm-bs)) outp) (write-bytes vm-bs outp) (write-byte (char->integer #\D) outp) @@ -73,15 +76,15 @@ name name-bstr 0))) - ;; Write order must correspond to a post-order traversal - ;; of the tree, so write + ;; Write order must correspond to a pre-order traversal + ;; of the tree, so sort (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] + [(null? a) #t] + [(null? b) #f] [(eq? (car a) (car b)) (loop (cdr a) (cdr b))] [(symbolfasl (hash-remove top 'vm) outp)] + [(#"chez-scheme") + (write-bundle-header #"chez-scheme" outp) + (define bstr (hash-ref top 'opaque + (lambda () + (error 'zo-marshal "missing 'opaque for chez-scheme virtual-machine format")))) + (write-bytes (integer->integer-bytes (bytes-length bstr) 4 #f #f) outp) + (write-bytes bstr outp)] + [else + (error 'zo-marshal "unknown virtual machine: ~a" (hash-ref top 'vm #f))])) + +(define (zo-marshal-racket-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 @@ -229,21 +249,7 @@ (define all-forms-length (out-compilation-top shared-obj-pos shared-obj-pos #f counting-port)) ; Write the compiled form header - (write-bytes #"#~" outp) - - ; Write the version (notice that it isn't the same as out-string) - (define version-bs (string->bytes/latin-1 (version))) - (write-bytes (bytes (bytes-length version-bs)) outp) - (write-bytes version-bs outp) - (define vm-bs #"racket") - (write-bytes (bytes (bytes-length vm-bs)) outp) - (write-bytes vm-bs 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) + (write-bundle-header #"racket" outp) ; Write the symbol table information (size, offsets) (define symtabsize (add1 (vector-length symbol-table))) @@ -261,6 +267,23 @@ (out-compilation-top shared-obj-pos shared-obj-pos #f outp) (void)) + +(define (write-bundle-header vm-bs outp) + (write-bytes #"#~" outp) + + ; Write the version (notice that it isn't the same as out-string) + (define version-bs (string->bytes/latin-1 (version))) + (write-bytes (bytes (bytes-length version-bs)) outp) + (write-bytes version-bs outp) + (write-bytes (bytes (bytes-length vm-bs)) outp) + (write-bytes vm-bs 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)) + ;; ---------------------------------------- (define toplevel-type-num 0) diff -Nru racket-7.2+ppa2/share/pkgs/zo-lib/compiler/zo-parse.rkt racket-7.3+ppa1/share/pkgs/zo-lib/compiler/zo-parse.rkt --- racket-7.2+ppa2/share/pkgs/zo-lib/compiler/zo-parse.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/zo-lib/compiler/zo-parse.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -208,7 +208,7 @@ [(22) 'case-lambda-sequence-type] [(23) 'inline-variant-type] [(25) 'linklet-type] - [(89) 'prefix-type] + [(88) 'prefix-type] [else (error 'int->type "unknown type: ~e" i)])) ;; ---------------------------------------- @@ -749,7 +749,7 @@ (define-values (vm mode) (read-prefix port #f)) (case mode - [(#\B) (linkl-bundle (zo-parse-top port vm))] + [(#\B) (linkl-bundle (hash-set (zo-parse-top port vm) 'vm vm))] [(#\D) (struct sub-info (name start len)) (define sub-infos @@ -796,10 +796,10 @@ [else (unless (eq? tag #\B) (error 'zo-parse "expected a bundle")) - (define sub (and tag (zo-parse-top port vm #f))) + (define sub (zo-parse-top port vm #f)) (unless (hash? sub) (error 'zo-parse "expected a bundle hash")) - (linkl-bundle sub)])) + (linkl-bundle (hash-set sub 'vm vm))])) (values (sub-info-name sub-info) sub))))] [else (error 'zo-parse "bad file format specifier")])) @@ -857,6 +857,10 @@ (set-cport-pos! cp shared-size) (make-reader-graph (read-compact cp))] + [(equal? vm #"chez-scheme") + (hash + 'opaque + (read-bytes (read-simple-number port) port))] [else (error 'zo-parse "cannot parse for virtual machine: ~s" vm)])) diff -Nru racket-7.2+ppa2/share/pkgs/zo-lib/info.rkt racket-7.3+ppa1/share/pkgs/zo-lib/info.rkt --- racket-7.2+ppa2/share/pkgs/zo-lib/info.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/share/pkgs/zo-lib/info.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1 +1 @@ -(module info setup/infotab (#%module-begin (define package-content-state (quote (built "7.2"))) (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.3"))) (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-7.2+ppa2/src/cify/generate.rkt racket-7.3+ppa1/src/cify/generate.rkt --- racket-7.2+ppa2/src/cify/generate.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/src/cify/generate.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -270,6 +270,7 @@ (runstack-push! runstack vals-id) (out "int ~a_count;" vals-id) (generate (multiple-return (lambda (s) + (out-open "{") (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) @@ -280,7 +281,8 @@ (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!))) + (out-close!) + (out-close "}"))) e env) (generate (multiple-return "") `(begin . ,r) env) (runstack-sync! runstack) diff -Nru racket-7.2+ppa2/src/common/queue.rkt racket-7.3+ppa1/src/common/queue.rkt --- racket-7.2+ppa2/src/common/queue.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/src/common/queue.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -2,7 +2,8 @@ ;; Mutable queue -(provide make-queue +(provide queue + make-queue queue-empty? queue-remove! queue-fremove! diff -Nru racket-7.2+ppa2/src/cs/c/boot.c racket-7.3+ppa1/src/cs/c/boot.c --- racket-7.2+ppa2/src/cs/c/boot.c 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/src/cs/c/boot.c 2019-05-16 01:29:07.000000000 +0000 @@ -74,6 +74,50 @@ return bv; } +static ptr parse_coldirs(char *s) +{ + iptr len = strlen(s); + + if (!len || !s[len+1]) { + /* empty string or only one string */ + return Sbytevector(s); + } + + /* multiple collects paths; put into a reversed list */ + { + ptr rev = Snil; + iptr delta = 0; + + while (s[delta]) { + len = strlen(s + delta); + rev = Scons(Sbytevector(s+delta), rev); + delta += len + 1; + } + + return rev; + } +} + +static void run_cross_server(char **argv) +{ + ptr c, a; + const char *target_machine = argv[1]; + const char *cross_server_patch_file = argv[2]; + const char *cross_server_library_file = argv[3]; + + c = Stop_level_value(Sstring_to_symbol("load")); /* original `load` */ + a = Sstring(cross_server_patch_file); + (void)Scall1(c, a); + + c = Stop_level_value(Sstring_to_symbol("load")); /* this is the patched `load` */ + a = Sstring(cross_server_library_file); + (void)Scall1(c, a); + c = Stop_level_value(Sstring_to_symbol("serve-cross-compile")); + + a = Sstring(target_machine); + (void)Scall1(c, a); +} + static void racket_exit(int v) { exit(v); @@ -96,16 +140,21 @@ char *coldir, char *configdir, /* wchar_t * */void *dlldir, int pos1, int pos2, int pos3, int cs_compiled_subdir, int is_gui, - int wm_is_gracket, char *gracket_guid, + int wm_is_gracket_or_x11_arg_count, + char *gracket_guid_or_x11_args, void *dll_open, void *dll_find_object) /* exe argument already stripped from argv */ { #if !defined(RACKET_USE_FRAMEWORK) || !defined(RACKET_AS_BOOT) int fd; #endif +#ifdef RACKET_AS_BOOT + int skip_racket_boot = 0; +#endif #ifdef RACKET_USE_FRAMEWORK const char *fw_path; #endif + int cross_server = 0; #ifdef WIN32 if (dlldir) @@ -116,12 +165,20 @@ Sscheme_init(NULL); + if ((argc == 4) && !strcmp(argv[0], "--cross-server")) { + cross_server = 1; +#ifdef RACKET_AS_BOOT + skip_racket_boot = 1; +#endif + } + #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")); # ifdef RACKET_AS_BOOT - Sregister_boot_file(path_append(fw_path, "racket.boot")); + if (!skip_racket_boot) + Sregister_boot_file(path_append(fw_path, "racket.boot")); # endif #else fd = open(boot_exe, O_RDONLY | BOOT_O_BINARY); @@ -138,15 +195,24 @@ Sregister_boot_file_fd("scheme", fd2); # ifdef RACKET_AS_BOOT - fd = open(boot_exe, O_RDONLY | BOOT_O_BINARY); - lseek(fd, pos3, SEEK_SET); - Sregister_boot_file_fd("racket", fd); + if (!skip_racket_boot) { + fd = open(boot_exe, O_RDONLY | BOOT_O_BINARY); + lseek(fd, pos3, SEEK_SET); + Sregister_boot_file_fd("racket", fd); + } # endif } #endif Sbuild_heap(NULL, init_foreign); - + + if (cross_server) { + /* Don't run Racket as usual. Instead, load the patch + file and run `serve-cross-compile` */ + run_cross_server(argv); + racket_exit(0); + } + { ptr l = Snil; int i; @@ -155,15 +221,15 @@ for (i = argc; i--; ) { l = Scons(Sbytevector(argv[i]), l); } - l = Scons(Sbytevector(gracket_guid), l); - sprintf(wm_is_gracket_s, "%d", wm_is_gracket); + l = Scons(Sbytevector(gracket_guid_or_x11_args), l); + sprintf(wm_is_gracket_s, "%d", wm_is_gracket_or_x11_arg_count); l = Scons(Sbytevector(wm_is_gracket_s), l); l = Scons(Sbytevector(is_gui ? "true" : "false"), l); l = Scons(Sbytevector(cs_compiled_subdir ? "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(parse_coldirs(coldir), l); l = Scons(Sbytevector(run_file), l); l = Scons(Sbytevector(exec_file), l); diff -Nru racket-7.2+ppa2/src/cs/c/boot.h racket-7.3+ppa1/src/cs/c/boot.h --- racket-7.2+ppa2/src/cs/c/boot.h 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/src/cs/c/boot.h 2019-05-16 01:29:07.000000000 +0000 @@ -3,7 +3,7 @@ char *coldir, char *configdir, /* wchar_t * */void *dlldir, int pos1, int pos2, int pos3, int cs_compiled_subdir, int is_gui, - int wm_is_gracket, char *gracket_guid, + int wm_is_gracket_or_x11_arg_count, char *gracket_guid_or_x11_args, void *ddll_open, void *dll_find_object); typedef void (*racket_boot_t)(int argc, char **argv, char *exec_file, char *run_file, @@ -11,5 +11,5 @@ char *coldir, char *configdir, /* wchar_t * */void *dlldir, int pos1, int pos2, int pos3, int cs_compiled_subdir, int is_gui, - int wm_is_gracket, char *gracket_guid, + int wm_is_gracket_or_x11_arg_count, char *gracket_guid_or_x11_args, void *ddll_open, void *dll_find_object); diff -Nru racket-7.2+ppa2/src/cs/c/configure racket-7.3+ppa1/src/cs/c/configure --- racket-7.2+ppa2/src/cs/c/configure 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/src/cs/c/configure 2019-05-16 01:29:07.000000000 +0000 @@ -622,19 +622,32 @@ ac_subst_vars='LTLIBOBJS LIBOBJS +INSTALL_SETUP_RACKET_FLAGS +INSTALL_SETUP_FLAGS +RUN_RACKET CROSS_COMPILE_TARGET_KIND +COMP_SUBDIR_CONFIGURE_ARGS CS_COMPILED_SUBDIR CS_INSTALLED +FRAMEWORK_REL_INSTALL FRAMEWORK_PREFIX FRAMEWORK_INSTALL_DIR +SCHEME_CROSS_CONFIG_ARGS SCHEME_CONFIG_ARGS MAKE_BUILD_SCHEME SCHEME_SRC ELF_COMP COMPRESS_COMP CONFIGURE_RACKET_SO_COMPILE +NOT_MINGW +MINGW NOT_OSX OSX +TT_CROSS_MODE +T_CROSS_MODE +CROSS_MODE +DIFF_MACH +TARGET_MACH MACH SCHEME_DIR RACKET @@ -645,14 +658,17 @@ STRIP_LIB_DEBUG STRIP_DEBUG ICP +WINDRES STATIC_AR -RANLIB ARFLAGS AR +LD EGREP GREP CPP STRIP +platform_ar_found +RANLIB OBJEXT EXEEXT ac_ct_CC @@ -754,6 +770,7 @@ enable_racket enable_scheme enable_mach +enable_target enable_sdk enable_xonx enable_macprefix @@ -1382,14 +1399,15 @@ --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-compress compress compiled code + --enable-compress compress compiled code (enabled by default) --enable-origtree install with original directory structure --enable-pkgscope= set `raco pkg' default: installation, user, or shared --enable-docs build docs on install (enabled by default) --enable-usersetup setup user-specific files on install --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 + --enable-mach= Use Chez Scheme machine type + --enable-target= Cross-build for Chez Scheme machine type --enable-sdk= use Mac OS 10.4 SDK directory --enable-sdk5= use Mac OS 10.5 SDK directory --enable-sdk6= use Mac OS 10.6 SDK directory @@ -2340,6 +2358,11 @@ enableval=$enable_mach; fi +# Check whether --enable-target was given. +if test "${enable_target+set}" = set; then : + enableval=$enable_target; +fi + # Check whether --enable-sdk was given. if test "${enable_sdk+set}" = set; then : enableval=$enable_sdk; @@ -2480,11 +2503,12 @@ show_explicitly_enabled "${enable_pthread}" "pthreads" show_explicitly_disabled "${enable_pthread}" "pthreads" -show_explicitly_enabled "${enable_compress}" "Compressed code" +show_explicitly_disabled "${enable_compress}" "Compressed code" 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" +show_explicitly_set "${enable_target}" "cross-build machine type" if test "${enable_csonly}" = "yes" ; then enable_csdefault=yes @@ -2586,11 +2610,12 @@ fi CS_COMPILED_SUBDIR=1 +COMP_SUBDIR_CONFIGURE_ARGS= if test "${enable_csdefault}" = "yes" ; then CS_COMPILED_SUBDIR=0 + COMP_SUBDIR_CONFIGURE_ARGS=--enable-csdefault fi - ############## Install targets ################ PREFIX_PATH_RELATIVE=/../.. @@ -2778,6 +2803,8 @@ INCLUDEDEP="#" OSX="not_osx" NOT_OSX="" +MINGW="not_mingw" +NOT_MINGW="" CONFIGURE_RACKET_SO_COMPILE="" COMPRESS_COMP="" ELF_COMP="" @@ -2786,6 +2813,10 @@ FRAMEWORK_PREFIX='@executable_path/../lib/' RACKET='$(DEFAULT_RACKET)' +RUN_RACKET='$(RUN_THIS_RACKET)' + +INSTALL_SETUP_FLAGS= +INSTALL_SETUP_RACKET_FLAGS= enable_pthread_by_default=yes @@ -3678,8 +3709,155 @@ fi +if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}ranlib", so it can be a program name with args. +set dummy ${ac_tool_prefix}ranlib; 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_RANLIB+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$RANLIB"; then + ac_cv_prog_RANLIB="$RANLIB" # 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_RANLIB="${ac_tool_prefix}ranlib" + $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 +RANLIB=$ac_cv_prog_RANLIB +if test -n "$RANLIB"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $RANLIB" >&5 +$as_echo "$RANLIB" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_RANLIB"; then + ac_ct_RANLIB=$RANLIB + # Extract the first word of "ranlib", so it can be a program name with args. +set dummy ranlib; 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_RANLIB+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$ac_ct_RANLIB"; then + ac_cv_prog_ac_ct_RANLIB="$ac_ct_RANLIB" # 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_RANLIB="ranlib" + $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_RANLIB=$ac_cv_prog_ac_ct_RANLIB +if test -n "$ac_ct_RANLIB"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_RANLIB" >&5 +$as_echo "$ac_ct_RANLIB" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + if test "x$ac_ct_RANLIB" = x; then + RANLIB=":" + 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 + RANLIB=$ac_ct_RANLIB + fi +else + RANLIB="$ac_cv_prog_RANLIB" +fi + +if test "$AR" = '' ; then + AR="${ac_tool_prefix}ar" + # Extract the first word of "$AR", so it can be a program name with args. +set dummy $AR; 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_platform_ar_found+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$platform_ar_found"; then + ac_cv_prog_platform_ar_found="$platform_ar_found" # 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_platform_ar_found="yes" + $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 + + test -z "$ac_cv_prog_platform_ar_found" && ac_cv_prog_platform_ar_found="no" +fi +fi +platform_ar_found=$ac_cv_prog_platform_ar_found +if test -n "$platform_ar_found"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $platform_ar_found" >&5 +$as_echo "$platform_ar_found" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + if test "$platform_ar_found" = 'no' ; then + AR="ar" + fi +fi +if test "$ARFLAGS" = '' ; then + ARFLAGS=ruv +fi + +LD="${ac_tool_prefix}ld" + +WINDRES=windres + ############## platform tests ################ +# At first, `MACH` means the target that we're building for. In +# cross-build mode, `MACH` will be moved to `TARGET_MACH`. + MACH_HOST_CPU="${host_cpu}" extra_scheme_config_args= disable_curses_arg=--disable-curses @@ -3717,6 +3895,13 @@ ;; *mingw*) skip_iconv_check=yes + use_flag_pthread=no + MACH_OS=nt + MINGW="" + NOT_MINGW="mingw" + if `which ${host}-windres > /dev/null` ; then + WINDRES="${host}-windres" + fi ;; cygwin*) ;; @@ -3724,6 +3909,7 @@ PREFLAGS="$PREFLAGS -DOS_X" MACH_OS=osx LIBS="${LIBS} -lncurses -framework CoreFoundation" + LDFLAGS="${LDFLAGS} -Wl,-headerpad_max_install_names" if test "${enable_xonx}" == "no" ; then INCLUDEDEP="-include" OSX="" @@ -3840,10 +4026,8 @@ fi thread_prefix="" -thread_config_arg="" if test "${enable_pthread}" = "yes" ; then thread_prefix="t" - thread_config_arg="--threads" fi case "$MACH_HOST_CPU" in @@ -3861,6 +4045,81 @@ ;; esac +if test "${enable_mach}" != "" ; then + MACH="${enable_mach}" +fi + +if test "${enable_target}" != "" ; then + TARGET_MACH=${enable_target} + CROSS_MODE="cross" +elif test "${build_os}_${build_cpu}" != "${host_os}_${host_cpu}" ; then + BUILD_THREAD_PREFIX="${thread_prefix}" + case "$build_os" in + solaris2*) + BUILD_OS=s2 + ;; + *freebsd*) + BUILD_OS=fb + ;; + openbsd*) + BUILD_OS=ob + ;; + netbsd*) + BUILD_OS=nb + ;; + linux*) + BUILD_OS=le + ;; + *mingw*) + BUILD_OS=nt + ;; + darwin*) + BUILD_OS=osx + ;; + nto-qnx*) + BUILD_OS=qnx + ;; + *) + echo "unknown build OS" + exit 1 + ;; + esac + case "$build_cpu" in + x86_64) + BUILD_MACH="${BUILD_THREAD_PREFIX}a6${BUILD_OS}" + ;; + x86|i*86) + BUILD_MACH="${BUILD_THREAD_PREFIX}i3${BUILD_OS}" + ;; + arm*) + BUILD_MACH="${BUILD_THREAD_PREFIX}arm32${BUILD_OS}" + ;; + power*) + BUILD_MACH="${BUILD_THREAD_PREFIX}ppc32${BUILD_OS}" + ;; + esac + TARGET_MACH=${MACH} + MACH=${BUILD_MACH} + CROSS_MODE="cross" +else + BUILD_MACH=${MACH} + TARGET_MACH=${MACH} + CROSS_MODE="" +fi + +if test "${CROSS_MODE}" = "cross" ; then + T_CROSS_MODE="-cross" + TT_CROSS_MODE="--cross" + RUN_RACKET='$(RACKET)' +else + T_CROSS_MODE="" + TT_CROSS_MODE="" +fi + +# From this point on, `MACH` means the build machine, and +# `TARGET_MACH` is the target that we're building for (which +# is different in cross-build mode). + SCHEME_SRC=../../ChezScheme MAKE_BUILD_SCHEME=y @@ -3873,16 +4132,18 @@ RACKET="${enable_racket}" fi -if test "${enable_mach}" != "" ; then - MACH="${enable_mach}" -fi - -SCHEME_CONFIG_ARGS="--machine=${MACH} ${thread_config_arg} --disable-x11 ${disable_curses_arg} ${extra_scheme_config_args}" +SCHEME_CONFIG_ARGS="--machine=${MACH} --disable-x11 ${disable_curses_arg} ${extra_scheme_config_args}" +SCHEME_CROSS_CONFIG_ARGS="--machine=${TARGET_MACH} --disable-x11 ${disable_curses_arg} ${extra_scheme_config_args}" -if test "${enable_compress}" = "yes" ; then +if test "${enable_compress}" != "no" ; then COMPRESS_COMP="--compress" fi +DIFF_MACH=skip +if test "${MACH}" != "${TARGET_MACH}" ; then + DIFF_MACH= +fi + ############## Strip tool ################ if test "${enable_strip}" = "" ; then @@ -4635,6 +4896,36 @@ ############## final output ################ +# Pass certain configure args on to rktio +keep_configure_args= +fixup_prev= +eval "set x $ac_configure_args" +shift +for fixup_arg +do + case $fixup_arg in + # Strip away all feature choices + -enable* | --enable* | -disable* | --disable*) + ;; + *) + case $fixup_arg in + *\'*) fixup_arg=`echo "$fixup_arg" | sed "s/'/'\\\\\\\\''/g"` ;; + esac + keep_configure_args="$keep_configure_args '$fixup_arg'" ;; + esac +done + +SUB_CONFIGURE_EXTRAS="${SUB_CONFIGURE_EXTRAS} CC="'"'"${CC}"'"' +SUB_CONFIGURE_EXTRAS="${SUB_CONFIGURE_EXTRAS} CFLAGS="'"'"${CFLAGS}"'"' +SUB_CONFIGURE_EXTRAS="${SUB_CONFIGURE_EXTRAS} LD="'"'"${LD}"'"' +SUB_CONFIGURE_EXTRAS="${SUB_CONFIGURE_EXTRAS} LDFLAGS="'"'"${LDFLAGS}"'"' +SUB_CONFIGURE_EXTRAS="${SUB_CONFIGURE_EXTRAS} AR="'"'"${AR}"'"' +SUB_CONFIGURE_EXTRAS="${SUB_CONFIGURE_EXTRAS} ARFLAGS="'"'"${ARFLAGS}"'"' +SUB_CONFIGURE_EXTRAS="${SUB_CONFIGURE_EXTRAS} RANLIB="'"'"${RANLIB}"'"' +SUB_CONFIGURE_EXTRAS="${SUB_CONFIGURE_EXTRAS} WINDRES="'"'"${WINDRES}"'"' + +############## final output ################ + CPPFLAGS="$CPPFLAGS $PREFLAGS" @@ -4670,6 +4961,21 @@ + + + + + + + + + + + + + + + makefiles="Makefile" ac_config_files="$ac_config_files $makefiles" @@ -5950,4 +6256,4 @@ mkdir -p rktio abssrcdir=`(cd ${srcdir}; pwd)` echo "=== configuring in rktio (${abssrcdir}/../../rktio)" -cd rktio; eval "${abssrcdir}/../../rktio/configure ${SUB_CONFIGURE_EXTRAS}" +cd rktio; eval "${abssrcdir}/../../rktio/configure ${keep_configure_args} ${SUB_CONFIGURE_EXTRAS}" diff -Nru racket-7.2+ppa2/src/cs/c/configure.ac racket-7.3+ppa1/src/cs/c/configure.ac --- racket-7.2+ppa2/src/cs/c/configure.ac 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/src/cs/c/configure.ac 2019-05-16 01:29:07.000000000 +0000 @@ -16,11 +16,12 @@ 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(compress, [ --enable-compress compress compiled code]) +AC_ARG_ENABLE(compress, [ --enable-compress compress compiled code (enabled by default)]) m4_include(../ac/path_arg.m4) 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 ]) +AC_ARG_ENABLE(mach, [ --enable-mach= Use Chez Scheme machine type ]) +AC_ARG_ENABLE(target, [ --enable-target= Cross-build for Chez Scheme machine type ]) m4_include(../ac/sdk_arg.m4) m4_include(../ac/strip_arg.m4) AC_ARG_ENABLE(csdefault, [ --enable-csdefault use CS as default build]) @@ -56,11 +57,12 @@ show_explicitly_enabled "${enable_pthread}" "pthreads" show_explicitly_disabled "${enable_pthread}" "pthreads" -show_explicitly_enabled "${enable_compress}" "Compressed code" +show_explicitly_disabled "${enable_compress}" "Compressed code" 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" +show_explicitly_set "${enable_target}" "cross-build machine type" if test "${enable_csonly}" = "yes" ; then enable_csdefault=yes @@ -91,11 +93,12 @@ fi CS_COMPILED_SUBDIR=1 +COMP_SUBDIR_CONFIGURE_ARGS= if test "${enable_csdefault}" = "yes" ; then CS_COMPILED_SUBDIR=0 + COMP_SUBDIR_CONFIGURE_ARGS=--enable-csdefault fi - ############## Install targets ################ PREFIX_PATH_RELATIVE=/../.. @@ -111,6 +114,8 @@ INCLUDEDEP="#" OSX="not_osx" NOT_OSX="" +MINGW="not_mingw" +NOT_MINGW="" CONFIGURE_RACKET_SO_COMPILE="" COMPRESS_COMP="" ELF_COMP="" @@ -119,6 +124,10 @@ FRAMEWORK_PREFIX='@executable_path/../lib/' RACKET='$(DEFAULT_RACKET)' +RUN_RACKET='$(RUN_THIS_RACKET)' + +INSTALL_SETUP_FLAGS= +INSTALL_SETUP_RACKET_FLAGS= enable_pthread_by_default=yes @@ -134,8 +143,27 @@ AC_CHECK_LIB(m, fmod) AC_CHECK_LIB(dl, dlopen) +AC_PROG_RANLIB +if test "$AR" = '' ; then + AR="${ac_tool_prefix}ar" + AC_CHECK_PROG(platform_ar_found, $AR, yes, no) + if test "$platform_ar_found" = 'no' ; then + AR="ar" + fi +fi +if test "$ARFLAGS" = '' ; then + ARFLAGS=ruv +fi + +LD="${ac_tool_prefix}ld" + +WINDRES=windres + ############## platform tests ################ +# At first, `MACH` means the target that we're building for. In +# cross-build mode, `MACH` will be moved to `TARGET_MACH`. + MACH_HOST_CPU="${host_cpu}" extra_scheme_config_args= disable_curses_arg=--disable-curses @@ -173,13 +201,21 @@ ;; *mingw*) skip_iconv_check=yes - ;; + use_flag_pthread=no + MACH_OS=nt + MINGW="" + NOT_MINGW="mingw" + if `which ${host}-windres > /dev/null` ; then + WINDRES="${host}-windres" + fi + ;; cygwin*) ;; darwin*) PREFLAGS="$PREFLAGS -DOS_X" MACH_OS=osx LIBS="${LIBS} -lncurses -framework CoreFoundation" + LDFLAGS="${LDFLAGS} -Wl,-headerpad_max_install_names" if test "${enable_xonx}" == "no" ; then INCLUDEDEP="-include" OSX="" @@ -242,10 +278,8 @@ fi thread_prefix="" -thread_config_arg="" if test "${enable_pthread}" = "yes" ; then thread_prefix="t" - thread_config_arg="--threads" fi case "$MACH_HOST_CPU" in @@ -263,6 +297,81 @@ ;; esac +if test "${enable_mach}" != "" ; then + MACH="${enable_mach}" +fi + +if test "${enable_target}" != "" ; then + TARGET_MACH=${enable_target} + CROSS_MODE="cross" +elif test "${build_os}_${build_cpu}" != "${host_os}_${host_cpu}" ; then + BUILD_THREAD_PREFIX="${thread_prefix}" + case "$build_os" in + solaris2*) + BUILD_OS=s2 + ;; + *freebsd*) + BUILD_OS=fb + ;; + openbsd*) + BUILD_OS=ob + ;; + netbsd*) + BUILD_OS=nb + ;; + linux*) + BUILD_OS=le + ;; + *mingw*) + BUILD_OS=nt + ;; + darwin*) + BUILD_OS=osx + ;; + nto-qnx*) + BUILD_OS=qnx + ;; + *) + echo "unknown build OS" + exit 1 + ;; + esac + case "$build_cpu" in + x86_64) + BUILD_MACH="${BUILD_THREAD_PREFIX}a6${BUILD_OS}" + ;; + x86|i*86) + BUILD_MACH="${BUILD_THREAD_PREFIX}i3${BUILD_OS}" + ;; + arm*) + BUILD_MACH="${BUILD_THREAD_PREFIX}arm32${BUILD_OS}" + ;; + power*) + BUILD_MACH="${BUILD_THREAD_PREFIX}ppc32${BUILD_OS}" + ;; + esac + TARGET_MACH=${MACH} + MACH=${BUILD_MACH} + CROSS_MODE="cross" +else + BUILD_MACH=${MACH} + TARGET_MACH=${MACH} + CROSS_MODE="" +fi + +if test "${CROSS_MODE}" = "cross" ; then + T_CROSS_MODE="-cross" + TT_CROSS_MODE="--cross" + RUN_RACKET='$(RACKET)' +else + T_CROSS_MODE="" + TT_CROSS_MODE="" +fi + +# From this point on, `MACH` means the build machine, and +# `TARGET_MACH` is the target that we're building for (which +# is different in cross-build mode). + SCHEME_SRC=../../ChezScheme MAKE_BUILD_SCHEME=y @@ -275,16 +384,18 @@ RACKET="${enable_racket}" fi -if test "${enable_mach}" != "" ; then - MACH="${enable_mach}" -fi +SCHEME_CONFIG_ARGS="--machine=${MACH} --disable-x11 ${disable_curses_arg} ${extra_scheme_config_args}" +SCHEME_CROSS_CONFIG_ARGS="--machine=${TARGET_MACH} --disable-x11 ${disable_curses_arg} ${extra_scheme_config_args}" -SCHEME_CONFIG_ARGS="--machine=${MACH} ${thread_config_arg} --disable-x11 ${disable_curses_arg} ${extra_scheme_config_args}" - -if test "${enable_compress}" = "yes" ; then +if test "${enable_compress}" != "no" ; then COMPRESS_COMP="--compress" fi +DIFF_MACH=skip +if test "${MACH}" != "${TARGET_MACH}" ; then + DIFF_MACH= +fi + ############## Strip tool ################ m4_include(../ac/strip.m4) @@ -435,17 +546,49 @@ ############## final output ################ +# Pass certain configure args on to rktio +keep_configure_args= +fixup_prev= +eval "set x $ac_configure_args" +shift +for fixup_arg +do + case $fixup_arg in + # Strip away all feature choices + -enable* | --enable* | -disable* | --disable*) + ;; + *) + case $fixup_arg in + *\'*) fixup_arg=`echo "$fixup_arg" | sed "s/'/'\\\\\\\\''/g"` ;; + esac + keep_configure_args="$keep_configure_args '$fixup_arg'" ;; + esac +done + +SUB_CONFIGURE_EXTRAS="${SUB_CONFIGURE_EXTRAS} CC="'"'"${CC}"'"' +SUB_CONFIGURE_EXTRAS="${SUB_CONFIGURE_EXTRAS} CFLAGS="'"'"${CFLAGS}"'"' +SUB_CONFIGURE_EXTRAS="${SUB_CONFIGURE_EXTRAS} LD="'"'"${LD}"'"' +SUB_CONFIGURE_EXTRAS="${SUB_CONFIGURE_EXTRAS} LDFLAGS="'"'"${LDFLAGS}"'"' +SUB_CONFIGURE_EXTRAS="${SUB_CONFIGURE_EXTRAS} AR="'"'"${AR}"'"' +SUB_CONFIGURE_EXTRAS="${SUB_CONFIGURE_EXTRAS} ARFLAGS="'"'"${ARFLAGS}"'"' +SUB_CONFIGURE_EXTRAS="${SUB_CONFIGURE_EXTRAS} RANLIB="'"'"${RANLIB}"'"' +SUB_CONFIGURE_EXTRAS="${SUB_CONFIGURE_EXTRAS} WINDRES="'"'"${WINDRES}"'"' + +############## final output ################ + CPPFLAGS="$CPPFLAGS $PREFLAGS" AC_SUBST(CC) AC_SUBST(CFLAGS) AC_SUBST(CPPFLAGS) +AC_SUBST(LD) AC_SUBST(LDFLAGS) AC_SUBST(LIBS) AC_SUBST(AR) AC_SUBST(ARFLAGS) AC_SUBST(RANLIB) AC_SUBST(STATIC_AR) +AC_SUBST(WINDRES) AC_SUBST(ICP) AC_SUBST(STRIP_DEBUG) AC_SUBST(STRIP_LIB_DEBUG) @@ -456,19 +599,32 @@ AC_SUBST(RACKET) AC_SUBST(SCHEME_DIR) AC_SUBST(MACH) +AC_SUBST(TARGET_MACH) +AC_SUBST(DIFF_MACH) +AC_SUBST(CROSS_MODE) +AC_SUBST(T_CROSS_MODE) +AC_SUBST(TT_CROSS_MODE) AC_SUBST(OSX) AC_SUBST(NOT_OSX) +AC_SUBST(MINGW) +AC_SUBST(NOT_MINGW) AC_SUBST(CONFIGURE_RACKET_SO_COMPILE) AC_SUBST(COMPRESS_COMP) AC_SUBST(ELF_COMP) AC_SUBST(SCHEME_SRC) AC_SUBST(MAKE_BUILD_SCHEME) AC_SUBST(SCHEME_CONFIG_ARGS) +AC_SUBST(SCHEME_CROSS_CONFIG_ARGS) AC_SUBST(FRAMEWORK_INSTALL_DIR) AC_SUBST(FRAMEWORK_PREFIX) +AC_SUBST(FRAMEWORK_REL_INSTALL) AC_SUBST(CS_INSTALLED) AC_SUBST(CS_COMPILED_SUBDIR) +AC_SUBST(COMP_SUBDIR_CONFIGURE_ARGS) AC_SUBST(CROSS_COMPILE_TARGET_KIND) +AC_SUBST(RUN_RACKET) +AC_SUBST(INSTALL_SETUP_FLAGS) +AC_SUBST(INSTALL_SETUP_RACKET_FLAGS) makefiles="Makefile" @@ -477,4 +633,4 @@ mkdir -p rktio abssrcdir=`(cd ${srcdir}; pwd)` echo "=== configuring in rktio (${abssrcdir}/../../rktio)" -cd rktio; eval "${abssrcdir}/../../rktio/configure ${SUB_CONFIGURE_EXTRAS}" +cd rktio; eval "${abssrcdir}/../../rktio/configure ${keep_configure_args} ${SUB_CONFIGURE_EXTRAS}" diff -Nru racket-7.2+ppa2/src/cs/c/convert-to-boot.ss racket-7.3+ppa1/src/cs/c/convert-to-boot.ss --- racket-7.2+ppa2/src/cs/c/convert-to-boot.ss 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/src/cs/c/convert-to-boot.ss 2019-05-16 01:29:07.000000000 +0000 @@ -1,17 +1,26 @@ (compile-compressed #f) -(define-values (src dest) +(define-values (src dest machine) (let loop ([args (command-line-arguments)]) (cond [(and (pair? args) (equal? (car args) "--compress")) (compile-compressed #t) (loop (cdr args))] + [(and (pair? args) + (equal? (car args) "--xpatch") + (pair? (cdr args))) + (load (cadr args)) + (loop (cddr args))] [(null? args) (error 'convert-to-boot "missing file arguments")] - [(and (pair? (cdr args)) (null? (cddr args))) - (values (car args) (cadr args))] + [(null? (cdr args)) + (error 'convert-to-boot "missing destination-file argument")] + [(null? (cddr args)) + (error 'convert-to-boot "missing machine argument")] + [(pair? (cdddr args)) + (error 'convert-to-boot "extra arguments after files")] [else - (error 'convert-to-boot "extra arguments after files")]))) + (values (car args) (cadr args) (caddr args))]))) -(make-boot-file dest '("petite" "scheme") src) +(#%$make-boot-file dest (string->symbol machine) '("petite" "scheme") src) diff -Nru racket-7.2+ppa2/src/cs/c/cross-serve.ss racket-7.3+ppa1/src/cs/c/cross-serve.ss --- racket-7.2+ppa2/src/cs/c/cross-serve.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/src/cs/c/cross-serve.ss 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,71 @@ +;; The client half of this interaction is in "cs/linklet/cross-compile.ss". + +;; Communication uses the Chez Scheme printer and reader so make the +;; server independent from Racket, although it is run by the Racket +;; executable. + +;; Suppress printout on startup: +(define original-output-port (current-output-port)) +(let-values ([(o get) (open-bytevector-output-port (current-transcoder))]) + (current-output-port o)) + +;; Server function to run after cross-compiler is loaded: +(define (serve-cross-compile target) + ;; Don't exit due to Ctl-C: + (keyboard-interrupt-handler void) + ;; Restore output + (current-output-port original-output-port) + ;; Racket compilation mode + (generate-inspector-information #f) + (enable-arithmetic-left-associative #t) + (generate-procedure-source-information #t) + (expand-omit-library-invocations #t) + ;; Set up the environment + (expand `(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))) + ;; Serve requests to compile or to fasl data: + (let ([in (standard-input-port)] + [out (standard-output-port)]) + (let loop () + (let ([cmd (get-u8 in)]) + (unless (eof-object? cmd) + (get-u8 in) ; newline + (let-values ([(o get) (open-bytevector-output-port)]) + (case (integer->char cmd) + [(#\c) + (compile-to-port (list `(lambda () ,(read-fasled in))) o)] + [(#\f) + ;; Reads host fasl format, then writes target fasl format + (let ([v (read-fasled in)]) + (parameterize ([#%$target-machine (string->symbol target)]) + (fasl-write v o)))] + [else + (error 'serve-cross-compile (format "unrecognized command: ~s" cmd))]) + (let ([result (get)] + [len-bv (make-bytevector 8)]) + (bytevector-u64-set! len-bv 0 (bytevector-length result) (endianness little)) + (put-bytevector out len-bv) + (put-bytevector out result) + (flush-output-port out))) + (loop)))))) + +;; ---------------------------------------- + +(define (read-fasled in) + (let ([len-bv (get-bytevector-n in 8)]) + (fasl-read (open-bytevector-input-port + (get-bytevector-n in (bytevector-u64-ref len-bv 0 (endianness little))))))) diff -Nru racket-7.2+ppa2/src/cs/c/embed-boot.rkt racket-7.3+ppa1/src/cs/c/embed-boot.rkt --- racket-7.2+ppa2/src/cs/c/embed-boot.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/src/cs/c/embed-boot.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -8,6 +8,7 @@ (define expect-elf? #f) (define alt-dests '()) +(define target #f) (command-line #:once-each @@ -15,6 +16,8 @@ (enable-compress!)] [("--expect-elf") "Record offset from ELF section" (set! expect-elf? #t)] + [("--target") machine "Select target machine" + (set! target machine)] #:multi [("++exe") src dest "Select an alternative executable" (set! alt-dests (cons (cons src dest) alt-dests))] @@ -39,12 +42,12 @@ bstr2 terminator bstr3 terminator)) (define pos - (case (path->string (system-library-subpath #f)) + (case (or target (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")] - [("win32\\x86_64" "win32\\i386") + [("ta6nt" "ti3nt" "win32\\x86_64" "win32\\i386") (copy-file src-file dest-file #t) (define-values (pe rsrcs) (call-with-input-file* dest-file diff -Nru racket-7.2+ppa2/src/cs/c/gen-system.rkt racket-7.3+ppa1/src/cs/c/gen-system.rkt --- racket-7.2+ppa2/src/cs/c/gen-system.rkt 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/src/cs/c/gen-system.rkt 2019-05-16 01:29:07.000000000 +0000 @@ -1,20 +1,53 @@ (module gen-system '#%kernel ;; Command-line argument: - + + ;; This file includes various inferences for cross-compilation, so it has + ;; to be updated for new cross-compilation targets. + + (define-values (machine) (string->symbol (vector-ref (current-command-line-arguments) 1))) + + (define-values (machine-lookup) + (lambda (l default) + (if (null? l) + default + (if (eq? (caar l) machine) + (cdar l) + (machine-lookup (cdr l) default))))) + + ;; Check for cross-compile to Windows: + (define-values (windows?) (machine-lookup '((ta6nt . #t) + (a6nt . #t) + (ti3nt . #t) + (i3nt . #t)) + #f)) + + (define-values (lib-subpath) + (machine-lookup '((ta6nt . "win32\\x86_64") + (a6nt . "win32\\x86_64") + (ti3nt . "win32\\i386") + (i3nt . "win32\\i386")) + (bytes->string/utf-8 (path->bytes (system-library-subpath #f))))) + (define-values (ht) - (hash 'os (system-type 'os) - 'word (system-type 'word) + (hash 'os (if windows? 'windows (system-type 'os)) + 'word (machine-lookup '((ta6nt . 64) + (a6nt . 64) + (ti3nt . 32) + (i3nt . 32)) + (system-type 'word)) 'gc 'cs 'vm 'chez-scheme 'link 'static - 'machine (bytes->string/utf-8 (path->bytes (system-library-subpath #f))) - 'so-suffix (system-type 'so-suffix) + 'machine lib-subpath + 'library-subpath (string->bytes/utf-8 lib-subpath) + 'library-subpath-convention (if windows? 'windows 'unix) + 'so-suffix (if windows? #".dll" (system-type 'so-suffix)) 'so-mode 'local 'fs-change '#(#f #f #f #f) 'target-machine (if (equal? "any" (vector-ref (current-command-line-arguments) 2)) #f - (string->symbol (vector-ref (current-command-line-arguments) 1))))) + machine))) (call-with-output-file (vector-ref (current-command-line-arguments) 0) diff -Nru racket-7.2+ppa2/src/cs/c/grmain.c racket-7.3+ppa1/src/cs/c/grmain.c --- racket-7.2+ppa2/src/cs/c/grmain.c 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/src/cs/c/grmain.c 2019-05-16 01:29:07.000000000 +0000 @@ -17,14 +17,16 @@ instance of the same app. */ char *check_for_another = "yes, please check for another"; -# include +# include # include "../start/win_single.inc" # define CHECK_SINGLE_INSTANCE #endif #include "main.c" -#ifdef OS_X +#if defined(WIN32) +static void pre_filter_cmdline_arguments(int *argc, char ***argv) { } +#elif defined(OS_X) # define wx_mac #else # define wx_xt @@ -32,6 +34,17 @@ static void scheme_register_process_global(const char *key, void *v) { +#ifdef OS_X + /* "PLT_IS_FOREGROUND_APP" is set in "main.sps" */ +#endif +#ifdef wx_xt + if (!strcmp(key, "PLT_X11_ARGUMENT_COUNT")) + x11_arg_count = (int)(intptr_t)v; + else if (!strcmp(key, "PLT_X11_ARGUMENTS")) { + x11_args = malloc(32); + sprintf(x11_args, "%p", v); + } +#endif } #include "../../start/gui_filter.inc" diff -Nru racket-7.2+ppa2/src/cs/c/main.c racket-7.3+ppa1/src/cs/c/main.c --- racket-7.2+ppa2/src/cs/c/main.c 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/src/cs/c/main.c 2019-05-16 01:29:07.000000000 +0000 @@ -5,7 +5,7 @@ #include #include #ifdef WIN32 -# include +# 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); @@ -303,8 +303,8 @@ #endif static int bytes_main(int argc, char **argv, - /* for Windows GUI mode */ - int wm_is_gracket, char *gracket_guid) + /* for Windows and X11 GUI modes */ + int wm_is_gracket_or_x11_arg_count, char *gracket_guid_or_x11_args) { char *boot_exe, *exec_file = argv[0], *run_file = NULL; int pos1, pos2, pos3; @@ -353,12 +353,12 @@ memcpy(&pos2, boot_file_data + boot_file_offset + 4, sizeof(pos2)); memcpy(&pos3, boot_file_data + boot_file_offset + 8, sizeof(pos2)); - boot_offset = 0; #ifdef ELF_FIND_BOOT_SECTION boot_offset = find_boot_section(boot_exe); -#endif -#ifdef WIN32 +#elif WIN32 boot_offset = find_resource_offset(dll_path, 259, boot_rsrc_offset); +#else + boot_offset = 0; #endif pos1 += boot_offset; @@ -370,13 +370,13 @@ extract_coldir(), extract_configdir(), extract_dlldir(), pos1, pos2, pos3, CS_COMPILED_SUBDIR, RACKET_IS_GUI, - wm_is_gracket, gracket_guid, + wm_is_gracket_or_x11_arg_count, gracket_guid_or_x11_args, embedded_dll_open, scheme_dll_find_object); return 0; } -#if defined(WIN32) && defined(CHECK_SINGLE_INSTANCE) +#if defined(WIN32) && (defined(CHECK_SINGLE_INSTANCE) || defined(__MINGW32__)) int APIENTRY WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR ignored, int nCmdShow) { int argc; @@ -387,11 +387,13 @@ argv = cmdline_to_argv(&argc, &normalized_path); +#ifdef CHECK_SINGLE_INSTANCE if (CheckSingleInstance(normalized_path, argv)) return 0; wm = wm_is_gracket; guid = GRACKET_GUID; - +#endif + return bytes_main(argc, argv, wm, guid); } #elif defined(WIN32) @@ -407,7 +409,10 @@ return bytes_main(argc, argv, 0, ""); } #else +static int x11_arg_count = 0; +static char *x11_args = "0"; + int main(int argc, char **argv) { - return bytes_main(argc, argv, 0, ""); + return bytes_main(argc, argv, x11_arg_count, x11_args); } #endif diff -Nru racket-7.2+ppa2/src/cs/c/Makefile.in racket-7.3+ppa1/src/cs/c/Makefile.in --- racket-7.2+ppa2/src/cs/c/Makefile.in 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/src/cs/c/Makefile.in 2019-05-16 01:29:07.000000000 +0000 @@ -10,11 +10,19 @@ SCHEME_INC = $(SCHEME_SRC)/$(MACH)/boot/$(MACH) SCHEME = $(SCHEME_BIN) -b $(SCHEME_INC)/petite.boot -b $(SCHEME_INC)/scheme.boot +TARGET_MACH = @TARGET_MACH@ +SCHEME_TARGET_INC = $(SCHEME_SRC)/$(TARGET_MACH)/boot/$(TARGET_MACH) + CC = @CC@ BASE_CFLAGS = @CFLAGS@ @CPPFLAGS@ -CFLAGS = $(BASE_CFLAGS) -I$(SCHEME_INC) -I$(srcdir)/../../rktio -Irktio -I. +CFLAGS = $(BASE_CFLAGS) -I$(SCHEME_TARGET_INC) -I$(srcdir)/../../rktio -Irktio -I. +LD = @LD@ LDFLAGS = @LDFLAGS@ LIBS = @LIBS@ +AR = @AR@ +ARFLAGS = @ARFLAGS@ +RANLIB = @RANLIB@ +WINDRES = @WINDRES@ STRIP_DEBUG = @STRIP_DEBUG@ STRIP_LIB_DEBUG = @STRIP_LIB_DEBUG@ @@ -35,6 +43,7 @@ etcpltdir = @etcpltdir@ sharepltdir = @sharepltdir@ collectsdir = @collectsdir@ +configdir = @etcpltdir@ ALLDIRINFO = "$(DESTDIR)$(bindir)" \ "$(DESTDIR)$(libpltdir)" @@ -44,7 +53,7 @@ @INCLUDEDEP@ @srcdir@/../../racket/version.mak cs: - $(MAKE) scheme + $(MAKE) scheme@T_CROSS_MODE@ $(MAKE) racket-so cd rktio; $(MAKE) $(MAKE) racketcs @@ -76,6 +85,7 @@ CS_PROGS = RACKET="$(RACKET)" SCHEME="$(SCHEME)" CONVERT_RACKET="$(CONVERT_RACKET)" CS_OPTS = COMPRESS_COMP=@COMPRESS_COMP@ +CS_OPTScross = $(CS_OPTS) CSO=$(MACH) CROSS_COMP="--xpatch $(SCHEME_SRC)/$(TARGET_MACH)/s/xpatch" build-racket-so: $(MAKE) @RKTL_PRE@expander@RKTL_POST@ @@ -84,7 +94,7 @@ $(MAKE) @RKTL_PRE@regexp@RKTL_POST@ $(MAKE) @RKTL_PRE@schemify@RKTL_POST@ $(MAKE) @RKTL_PRE@known@RKTL_POST@ - cd $(srcdir)/.. && $(RACKET_SO_ENV) $(MAKE) "$(builddir)/racket.so" $(CS_PROGS) $(CS_OPTS) BUILDDIR="$(builddir)/" + cd $(srcdir)/.. && $(RACKET_SO_ENV) $(MAKE) "$(builddir)/racket.so" $(CS_PROGS) $(CS_OPTS@CROSS_MODE@) BUILDDIR="$(builddir)/" bounce: $(RACKET) -O 'info@compiler/cm' $(ABS_BOOT) $(srcdir)/../absify.rkt just-to-compile-absify @@ -121,25 +131,44 @@ if [ "$(MAKE_BUILD_SCHEME)" = "y" ] ; \ then $(MAKE) scheme-make ; fi +SCHEME_CONFIG_VARS = CC="$(CC)" CFLAGS="$(BASE_CFLAGS)" LD="$(LD)" LDFLAGS="$(LDFLAGS)" \ + AR="$(AR)" ARFLAGS="$(ARFLAGS)" RANLIB="$(RANLIB)" \ + WINDRES="$(WINDRES)" + scheme-make: - cd @SCHEME_SRC@ && ./configure @SCHEME_CONFIG_ARGS@ CC="$(CC)" CFLAGS="$(BASE_CFLAGS)" LDFLAGS="$(LDFLAGS)" - mkdir -p @SCHEME_SRC@/@MACH@/boot/@MACH@ - $(MAKE) @SCHEME_SRC@/@MACH@/boot/@MACH@/equates.h - $(MAKE) @SCHEME_SRC@/@MACH@/boot/@MACH@/petite.boot - $(MAKE) @SCHEME_SRC@/@MACH@/boot/@MACH@/scheme.boot - cd @SCHEME_SRC@ && $(MAKE) + cd $(SCHEME_SRC) && git submodule -q init && git submodule -q update + cd $(SCHEME_SRC) && ./configure @SCHEME_CONFIG_ARGS@ $(SCHEME_CONFIG_VARS) + mkdir -p $(SCHEME_SRC)/$(MACH)/boot/$(MACH) + $(MAKE) $(SCHEME_SRC)/$(MACH)/boot/$(MACH)/equates.h + $(MAKE) $(SCHEME_SRC)/$(MACH)/boot/$(MACH)/petite.boot + $(MAKE) $(SCHEME_SRC)/$(MACH)/boot/$(MACH)/scheme.boot + cd $(SCHEME_SRC) && $(MAKE) # Replace "equates.h", etc., if they seem to be out of date. -# Otherwise, `make` on Chez Scheme cna fail. -@SCHEME_SRC@/@MACH@/boot/@MACH@/equates.h: @SCHEME_SRC@/boot/@MACH@/equates.h - cp @SCHEME_SRC@/boot/@MACH@/equates.h @SCHEME_SRC@/@MACH@/boot/@MACH@/equates.h -@SCHEME_SRC@/@MACH@/boot/@MACH@/petite.boot: @SCHEME_SRC@/boot/@MACH@/petite.boot - cp @SCHEME_SRC@/boot/@MACH@/petite.boot @SCHEME_SRC@/@MACH@/boot/@MACH@/petite.boot -@SCHEME_SRC@/@MACH@/boot/@MACH@/scheme.boot: @SCHEME_SRC@/boot/@MACH@/scheme.boot - cp @SCHEME_SRC@/boot/@MACH@/scheme.boot @SCHEME_SRC@/@MACH@/boot/@MACH@/scheme.boot +# Otherwise, `make` on Chez Scheme can fail. +$(SCHEME_SRC)/$(MACH)/boot/$(MACH)/equates.h: $(SCHEME_SRC)/boot/$(MACH)/equates.h + cp $(SCHEME_SRC)/boot/$(MACH)/equates.h $(SCHEME_SRC)/$(MACH)/boot/$(MACH)/equates.h +$(SCHEME_SRC)/$(MACH)/boot/$(MACH)/petite.boot: $(SCHEME_SRC)/boot/$(MACH)/petite.boot + cp $(SCHEME_SRC)/boot/$(MACH)/petite.boot $(SCHEME_SRC)/$(MACH)/boot/$(MACH)/petite.boot +$(SCHEME_SRC)/$(MACH)/boot/$(MACH)/scheme.boot: $(SCHEME_SRC)/boot/$(MACH)/scheme.boot + cp $(SCHEME_SRC)/boot/$(MACH)/scheme.boot $(SCHEME_SRC)/$(MACH)/boot/$(MACH)/scheme.boot + +scheme-cross: + cd $(SCHEME_SRC) && git submodule -q init && git submodule -q update + cd $(SCHEME_SRC) && ./configure @SCHEME_CROSS_CONFIG_ARGS@ $(SCHEME_CONFIG_VARS) + cd $(SCHEME_SRC)/$(TARGET_MACH)/c && $(MAKE) o=o cross=t + $(MAKE) $(SCHEME_SRC)/$(TARGET_MACH)/s/xpatch + +# Rebuild patch file and cross "petite.boot" and "scheme.boot" when older +# than the build-host "scheme.boot" +$(SCHEME_SRC)/$(TARGET_MACH)/s/xpatch: $(SCHEME_SRC)/$(MACH)/boot/$(MACH)/scheme.boot + cd $(SCHEME_SRC)/$(TARGET_MACH)/s && $(MAKE) -f Mf-cross m=$(MACH) xm=$(TARGET_MACH) Scheme="$(SCHEME_BIN)" SCHEMEHEAPDIRS="$(SCHEME_INC)" + +XPATCH = +XPATCHcross = --xpatch $(SCHEME_SRC)/$(TARGET_MACH)/s/xpatch racket.boot: racket.so - $(SCHEME) --script $(srcdir)/convert-to-boot.ss @COMPRESS_COMP@ racket.so racket.boot + $(SCHEME) --script $(srcdir)/convert-to-boot.ss @COMPRESS_COMP@ $(XPATCH@CROSS_MODE@) racket.so racket.boot $(TARGET_MACH) @INCLUDEDEP@ compiled/expander.d @INCLUDEDEP@ compiled/thread.d @@ -153,13 +182,13 @@ EMBED_DEPS = $(srcdir)/embed-boot.rkt -racketcs@NOT_OSX@: raw_racketcs petite-v.boot scheme-v.boot racket-v.boot $(EMBED_DEPS) +racketcs@NOT_OSX@@NOT_MINGW@: raw_racketcs petite-v.boot scheme-v.boot racket-v.boot $(EMBED_DEPS) $(BOOTSTRAP_RACKET) $(srcdir)/embed-boot.rkt @ELF_COMP@ @COMPRESS_COMP@ raw_racketcs racketcs petite-v.boot scheme-v.boot racket-v.boot -gracketcs@NOT_OSX@: raw_gracketcs petite-v.boot scheme-v.boot racket-v.boot $(EMBED_DEPS) +gracketcs@NOT_OSX@@NOT_MINGW@: raw_gracketcs petite-v.boot scheme-v.boot racket-v.boot $(EMBED_DEPS) $(BOOTSTRAP_RACKET) $(srcdir)/embed-boot.rkt @ELF_COMP@ @COMPRESS_COMP@ raw_gracketcs gracketcs petite-v.boot scheme-v.boot racket-v.boot -BOOT_OBJS = boot.o $(SCHEME_INC)/kernel.o rktio/librktio.a +BOOT_OBJS = boot.o $(SCHEME_TARGET_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) @@ -167,14 +196,14 @@ raw_gracketcs: grmain.o boot.o $(BOOT_OBJS) $(CC) $(CFLAGS) -o raw_gracketcs grmain.o $(BOOT_OBJS) $(LDFLAGS) $(LIBS) -petite-v.boot: $(SCHEME_INC)/petite.boot - $(SCHEME) --script $(srcdir)/to-vfasl.ss @COMPRESS_COMP@ $(SCHEME_INC)/petite.boot petite-v.boot +petite-v.boot: $(SCHEME_TARGET_INC)/petite.boot + $(SCHEME) --script $(srcdir)/to-vfasl.ss @COMPRESS_COMP@ @TT_CROSS_MODE@ $(SCHEME_TARGET_INC)/petite.boot petite-v.boot -scheme-v.boot: $(SCHEME_INC)/scheme.boot - $(SCHEME) --script $(srcdir)/to-vfasl.ss @COMPRESS_COMP@ $(SCHEME_INC)/scheme.boot scheme-v.boot petite +scheme-v.boot: $(SCHEME_TARGET_INC)/scheme.boot + $(SCHEME) --script $(srcdir)/to-vfasl.ss @COMPRESS_COMP@ @TT_CROSS_MODE@ $(SCHEME_TARGET_INC)/scheme.boot scheme-v.boot petite racket-v.boot: racket.boot - $(SCHEME) --script $(srcdir)/to-vfasl.ss @COMPRESS_COMP@ racket.boot racket-v.boot petite scheme + $(SCHEME) --script $(srcdir)/to-vfasl.ss @COMPRESS_COMP@ @TT_CROSS_MODE@ racket.boot racket-v.boot petite scheme # ---------------------------------------- # Mac OS @@ -184,7 +213,7 @@ GRAPPSKEL = GRacketCS.app/Contents/Info.plist racketcs@OSX@: main.o $(RKTFW) - $(CC) $(CFLAGS) -o racketcs main.o -F. -framework Racket + $(CC) $(CFLAGS) -o racketcs main.o -F. -framework Racket $(LDFLAGS) /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 @@ -193,31 +222,116 @@ $(MAKE) $(GRACKET_BIN) $(GRACKET_BIN): grmain.o $(RKTFW) $(GRAPPSKEL) - $(CC) $(CFLAGS) -o $(GRACKET_BIN) grmain.o -F. -framework Racket + $(CC) $(CFLAGS) -o $(GRACKET_BIN) grmain.o -F. -framework Racket $(LDFLAGS) /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 $(BOOTSTRAP_RACKET) $(srcdir)/../../mac/osx_appl.rkt $(srcdir)/../.. "CS" -BOOT_FILES = $(SCHEME_INC)/petite.boot $(SCHEME_INC)/scheme.boot racket.boot +BOOT_FILES = $(SCHEME_TARGET_INC)/petite.boot $(SCHEME_TARGET_INC)/scheme.boot racket.boot FW_BOOT_DEST = Racket.framework/Versions/$(FWVERSION)_CS/boot $(RKTFW): $(BOOT_OBJS) $(BOOT_FILES) mkdir -p Racket.framework/Versions/$(FWVERSION)_CS - @RKTLINKER@ -o $(RKTFW) @LDFLAGS@ -dynamiclib -all_load $(BOOT_OBJS) $(LDFLAGS) $(LIBS) + @RKTLINKER@ -o $(RKTFW) -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 - $(SCHEME) --script $(srcdir)/to-vfasl.ss @COMPRESS_COMP@ $(SCHEME_INC)/petite.boot $(FW_BOOT_DEST)/petite.boot - $(SCHEME) --script $(srcdir)/to-vfasl.ss @COMPRESS_COMP@ $(SCHEME_INC)/scheme.boot $(FW_BOOT_DEST)/scheme.boot petite - $(SCHEME) --script $(srcdir)/to-vfasl.ss @COMPRESS_COMP@ racket.boot $(FW_BOOT_DEST)/racket.boot petite scheme + $(SCHEME) --script $(srcdir)/to-vfasl.ss @COMPRESS_COMP@ @TT_CROSS_MODE@ $(SCHEME_TARGET_INC)/petite.boot $(FW_BOOT_DEST)/petite.boot + $(SCHEME) --script $(srcdir)/to-vfasl.ss @COMPRESS_COMP@ @TT_CROSS_MODE@ $(SCHEME_TARGET_INC)/scheme.boot $(FW_BOOT_DEST)/scheme.boot petite + $(SCHEME) --script $(srcdir)/to-vfasl.ss @COMPRESS_COMP@ @TT_CROSS_MODE@ racket.boot $(FW_BOOT_DEST)/racket.boot petite scheme $(BOOTSTRAP_RACKET) $(srcdir)/adjust-compress.rkt @COMPRESS_COMP@ $(FW_BOOT_DEST)/petite.boot $(FW_BOOT_DEST)/scheme.boot $(FW_BOOT_DEST)/racket.boot # ---------------------------------------- +# MinGW + +racketcs@MINGW@: + $(MAKE) RacketCS.exe + +gracketcs@MINGW@: + $(MAKE) GRacketCS.exe + +RKT_DLL = libracketcsxxxxxxx.dll +EXE_DESTS = ++exe raw_racketcs.exe RacketCS.exe ++exe raw_gracketcs.exe GRacketCS.exe +V_BOOTS = petite-v.boot scheme-v.boot racket-v.boot + +RacketCS.exe GRacketCS.exe $(RKT_DLL): raw_libracketcs.dll raw_gracketcs.exe raw_racketcs.exe $(EMBED_DEPS) $(V_BOOTS) + $(BOOTSTRAP_RACKET) $(srcdir)/embed-boot.rkt --target $(TARGET_MACH) @COMPRESS_COMP@ $(EXE_DESTS) raw_libracketcs.dll $(RKT_DLL) $(V_BOOTS) + +raw_racketcs.exe: main.o MemoryModule.o rres.o + $(CC) $(CFLAGS) -o raw_racketcs.exe main.o MemoryModule.o rres.o $(LDFLAGS) + +raw_gracketcs.exe: grmain.o MemoryModule.o grres.o + $(CC) $(CFLAGS) -mwindows -o raw_gracketcs.exe grmain.o MemoryModule.o grres.o $(LDFLAGS) + +MINGW_LIBS = -lshell32 -luser32 -lole32 -lrpcrt4 -luuid -lws2_32 -ladvapi32 + +raw_libracketcs.dll: boot.o $(BOOT_OBJS) libres.o + $(CC) $(CFLAGS) --shared -o raw_libracketcs.dll $(BOOT_OBJS) libres.o $(LDFLAGS) rktio/librktio.a $(MINGW_LIBS) -static-libgcc $(LIBS) + +MemoryModule.o: $(srcdir)/../../start/MemoryModule.c + $(CC) -c $(CFLAGS) -o MemoryModule.o $(srcdir)/../../start/MemoryModule.c + +rres.o: $(srcdir)/../../worksp/racket/racket.rc $(srcdir)/../../worksp/racket/racket.ico + @WINDRES@ -i $(srcdir)/../../worksp/racket/racket.rc -o rres.o + +grres.o: $(srcdir)/../../worksp/gracket/gracket.rc $(srcdir)/../../worksp/gracket/gracket.ico + @WINDRES@ -i $(srcdir)/../../worksp/gracket/gracket.rc -o grres.o + +libres.o: $(srcdir)/../../worksp/cs/libracket.rc + @WINDRES@ -i $(srcdir)/../../worksp/cs/libracket.rc -o libres.o + +starter@MINGW@: + $(MAKE) MzStart.exe + $(MAKE) MrStart.exe + +MzStart.exe: $(srcdir)/../../start/start.c start_rc.o + $(CC) $(CFLAGS) -o MzStart.exe -DMZSTART $(srcdir)/../../start/start.c start_rc.o + +MrStart.exe: $(srcdir)/../../start/start.c gstart_rc.o + $(CC) -mwindows $(CFLAGS) -o MrStart.exe -DMRSTART $(srcdir)/../../start/start.c gstart_rc.o + +start_rc.o: $(srcdir)/../../worksp/starters/start.rc + @WINDRES@ -DMZSTART -i $(srcdir)/../../worksp/starters/start.rc -o start_rc.o + +gstart_rc.o: $(srcdir)/../../worksp/starters/start.rc + @WINDRES@ -DMRSTART -i $(srcdir)/../../worksp/starters/start.rc -o gstart_rc.o + +install@MINGW@: + $(MAKE) plain-install + +plain-install@MINGW@: + $(MAKE) plain-install-upcased CS_INSTALLED=`echo $(CS_INSTALLED) | awk '{print toupper($0)}'` + +plain-install-upcased: + $(ICP) libracketcsxxxxxxx.dll $(libdir)/libracketcsxxxxxxx.dll + $(ICP) RacketCS.exe $(prefix)/Racket$(CS_INSTALLED).exe + $(ICP) GRacketCS.exe $(libpltdir)/GRacket$(CS_INSTALLED).exe + $(ICP) MzStart.exe $(libpltdir)/MzStart.exe + $(ICP) MrStart.exe $(libpltdir)/MrStart.exe + $(MAKE) system-install + $(MAKE) compile-xpatch.$(TARGET_MACH) + $(MAKE) library-xpatch.$(TARGET_MACH) + +SCHEME_XPATCH = $(SCHEME_SRC)/$(TARGET_MACH)/s/xpatch + +compile-xpatch.$(TARGET_MACH): $(SCHEME_XPATCH) $(srcdir)/mk-cross-serve.ss $(srcdir)/cross-serve.ss + $(SCHEME) --script $(srcdir)/mk-cross-serve.ss $(srcdir)/cross-serve.ss + cat cross-serve.so $(SCHEME_XPATCH) > compile-xpatch.$(TARGET_MACH) + +RACKET_XPATCH = chezpart.$(MACH) rumble.$(MACH) thread.$(MACH) \ + io.$(MACH) regexp.$(MACH) schemify.$(MACH) linklet.$(MACH) expander.$(MACH) + +library-xpatch.$(TARGET_MACH): $(RACKET_XPATCH) + cat $(RACKET_XPATCH) > library-xpatch.$(TARGET_MACH) + +# ---------------------------------------- # Common -DEF_COLLECTS_DIR = -DINITIAL_COLLECTS_DIRECTORY='"'"`cd $(srcdir)/../../../collects; pwd`"'"' -DEF_CONFIG_DIR = -DINITIAL_CONFIG_DIRECTORY='"'"`cd $(srcdir)/../../..; pwd`/etc"'"' +DEF_COLLECTS_DIR@NOT_MINGW@ = -DINITIAL_COLLECTS_DIRECTORY='"'"`cd $(srcdir)/../../../collects; pwd`"'"' +DEF_CONFIG_DIR@NOT_MINGW@ = -DINITIAL_CONFIG_DIRECTORY='"'"`cd $(srcdir)/../../..; pwd`/etc"'"' +DEF_COLLECTS_DIR@MINGW@ = +DEF_CONFIG_DIR@MINGW@ = DEF_C_DIRS = $(DEF_COLLECTS_DIR) $(DEF_CONFIG_DIR) COMP_SUBDIR = -DCS_COMPILED_SUBDIR=@CS_COMPILED_SUBDIR@ @@ -232,7 +346,7 @@ 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 +starter@NOT_MINGW@: $(srcdir)/../../start/ustart.c $(CC) $(CFLAGS) -o starter $(srcdir)/../../start/ustart.c # ---------------------------------------- @@ -240,17 +354,27 @@ ICP=@ICP@ -install: +install@NOT_MINGW@: $(MAKE) plain-install $(MAKE) setup-install +# RUN_RACKET typically redirects to RUN_THIS_RACKET, but it can also +# redirect to a compatible existing Racket executable (e.g., for +# cross-compilation) +RUN_THIS_RACKET = $(DESTDIR)$(bindir)/racket$(CS_INSTALLED) + +INST_CONFIG = -X "$(DESTDIR)$(collectsdir)" -G "$(DESTDIR)$(configdir)" +SETUP_RACKET_FLAGS = $(INST_CONFIG) $(SETUP_MACHINE_FLAGS) $(SELF_RACKET_FLAGS) @INSTALL_SETUP_RACKET_FLAGS@ +SETUP_SETUP_FLAGS = @INSTALL_SETUP_FLAGS@ $(PLT_SETUP_OPTIONS) $(PLT_ISO) +SETUP_ARGS = $(SETUP_RACKET_FLAGS) -N "raco" -l- setup $(SETUP_SETUP_FLAGS) + setup-install: - $(DESTDIR)$(bindir)/racket$(CS_INSTALLED) $(SELF_RACKET_FLAGS) -N raco -l- raco setup $(PLT_SETUP_OPTIONS) + @RUN_RACKET@ $(SELF_RACKET_FLAGS) $(SETUP_ARGS) no-setup-install: echo done -plain-install@NOT_OSX@: +plain-install@NOT_OSX@@NOT_MINGW@: $(MAKE) unix-install plain-install@OSX@: @@ -267,7 +391,10 @@ $(STRIP_DEBUG) "$(DESTDIR)$(libpltdir)/starter" $(ICP) $(srcdir)/../../start/starter-sh "$(DESTDIR)$(libpltdir)/starter-sh" $(RACKET) -cu "$(srcdir)/../../racket/collects-path.rkt" "$(DESTDIR)$(libpltdir)/starter" $(DESTDIR)@COLLECTS_PATH@ $(DESTDIR)@CONFIG_PATH@ - $(RACKET) -cu "$(srcdir)/gen-system.rkt" $(DESTDIR)$(libpltdir)/system$(CS_INSTALLED).rktd $(MACH) @CROSS_COMPILE_TARGET_KIND@ + $(MAKE) system-install + +system-install: + $(RACKET) -cu "$(srcdir)/gen-system.rkt" $(DESTDIR)$(libpltdir)/system$(CS_INSTALLED).rktd $(TARGET_MACH) @CROSS_COMPILE_TARGET_KIND@ unix-install: $(MAKE) common-install @@ -284,6 +411,7 @@ $(MAKE) common-install rm -f $(DESTDIR)$(RKTFWDEST)/Racket rm -rf $(DESTDIR)$(RKTFWDEST)/Versions/$(FWVERSION)_CS + if [ @FRAMEWORK_REL_INSTALL@ = yes ] ; then $(RACKET) -cu "$(srcdir)/../../mac/clean-fw.rkt" $(DESTDIR)$(RKTFWDEST) ; fi mkdir -p $(DESTDIR)"$(RKTFWDEST)/Versions/$(FWVERSION)_CS" cp $(RKTFW) $(DESTDIR)$(RKTFWDEST)/Versions/$(FWVERSION)_CS/ mkdir -p $(DESTDIR)"$(RKTFWDEST)/Versions/$(FWVERSION)_CS/boot" @@ -304,3 +432,19 @@ /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) -cu "$(srcdir)/../../racket/collects-path.rkt" $(DESTDIR)"$(libpltdir)/GRacket$(CS_GR_INSTALLED).app/Contents/MacOS/GRacket$(CS_GR_INSTALLED)" ../../../../collects ../../../../etc $(STRIP_DEBUG) $(DESTDIR)"$(libpltdir)/GRacket$(CS_GR_INSTALLED).app/Contents/MacOS/GRacket$(CS_GR_INSTALLED)" + rm -rf $(DESTDIR)"$(libpltdir)/Starter.app" + $(ICP) -r Starter.app $(DESTDIR)"$(libpltdir)/." + +# ---------------------------------------- +# Reconfigure + +COMP_SUBDIR_CONFIGURE_ARGS=@COMP_SUBDIR_CONFIGURE_ARGS@ + +CONFIGURE_SRCS = $(srcdir)/configure $(srcdir)/Makefile.in \ + $(srcdir)/../../rktio/Makefile.in $(srcdir)/../../rktio/configure + +reconfigure: + $(MAKE) Makefile + +Makefile: $(CONFIGURE_SRCS) + $(srcdir)/configure $(COMP_SUBDIR_CONFIGURE_ARGS) $(CONFIGURE_ARGS_qq) $(MORE_CONFIGURE_ARGS) diff -Nru racket-7.2+ppa2/src/cs/c/mk-cross-serve.ss racket-7.3+ppa1/src/cs/c/mk-cross-serve.ss --- racket-7.2+ppa2/src/cs/c/mk-cross-serve.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/src/cs/c/mk-cross-serve.ss 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,2 @@ +(let ([args (command-line-arguments)]) + (compile-file (car args) "cross-serve.so")) diff -Nru racket-7.2+ppa2/src/cs/c/to-vfasl.ss racket-7.3+ppa1/src/cs/c/to-vfasl.ss --- racket-7.2+ppa2/src/cs/c/to-vfasl.ss 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/src/cs/c/to-vfasl.ss 2019-05-16 01:29:07.000000000 +0000 @@ -1,4 +1,5 @@ (compile-compressed #f) +(define compile-cross? #f) (define-values (src dest deps) (let loop ([args (command-line-arguments)]) @@ -7,6 +8,10 @@ (equal? (car args) "--compress")) (compile-compressed #t) (loop (cdr args))] + [(and (pair? args) + (equal? (car args) "--cross")) + (set! compile-cross? #t) + (loop (cdr args))] [(null? args) (error 'to-vfasl "missing src argument")] [(null? (cdr args)) @@ -14,4 +19,17 @@ [else (values (car args) (cadr args) (cddr args))]))) -(vfasl-convert-file src dest deps) +(cond + [compile-cross? + (printf "Cross-compile cannot convert to vfasl; leaving as-is\n") + (let ([i (open-file-input-port src)] + [o (open-file-output-port dest (file-options no-fail))]) + (let loop () + (define c (get-u8 i)) + (unless (eof-object? c) + (put-u8 o c) + (loop))) + (close-port i) + (close-port o))] + [else + (vfasl-convert-file src dest deps)]) diff -Nru racket-7.2+ppa2/src/cs/chezpart.sls racket-7.3+ppa1/src/cs/chezpart.sls --- racket-7.2+ppa2/src/cs/chezpart.sls 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/src/cs/chezpart.sls 2019-05-16 01:29:07.000000000 +0000 @@ -38,7 +38,8 @@ get-thread-id threaded? map for-each andmap ormap - char-general-category) + char-general-category + make-vector make-string) [make-parameter chez:make-parameter] [date-second chez:date-second] [date-minute chez:date-minute] diff -Nru racket-7.2+ppa2/src/cs/compile-file.ss racket-7.3+ppa1/src/cs/compile-file.ss --- racket-7.2+ppa2/src/cs/compile-file.ss 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/src/cs/compile-file.ss 2019-05-16 01:29:07.000000000 +0000 @@ -2,6 +2,14 @@ ;; Check to make we're using a build of Chez Scheme ;; that has all the features we need. +(let-values ([(maj min sub) (scheme-version-number)]) + (unless (or (> maj 9) + (and (= maj 9) + (or (> min 5) + (and (= min 5) + (>= sub 3))))) + (error 'compile-file "need a newer Chez Scheme"))) + (define (check-ok what thunk) (unless (guard (x [else #f]) (thunk)) (error 'compile-file @@ -34,6 +42,20 @@ (eval '(f (fxvector 0)))))) (check-defined 'vfasl-convert-file) (check-defined 'compute-size-increments) +(check-defined 'enable-type-recovery) +(check-defined 'make-wrapper-procedure) +(check-defined 'make-phantom-bytevector) +(check-defined 'enable-arithmetic-left-associative) +(check-ok "eq? on flonums" + (lambda () + (let* ([n (string->number "3.14")] + [v (vector n n)]) + (collect 0) + (unless (eq? (vector-ref v 0) (vector-ref v 1)) + (error 'eq-on-flonum "no"))))) +(check-defined 'procedure-known-single-valued?) +(check-defined 'compress-format) +(check-defined '#%$record-cas!) ;; ---------------------------------------- @@ -58,9 +80,11 @@ (define whole-program? #f) (generate-inspector-information #f) -(generate-procedure-source-information #t) +(generate-procedure-source-information #f) (compile-compressed #f) +(enable-arithmetic-left-associative #t) (define build-dir "") +(define xpatch-path #f) (define-values (src deps) (let loop ([args (command-line-arguments)]) @@ -69,6 +93,10 @@ => (lambda (args) (generate-inspector-information #t) (loop args))] + [(get-opt args "--srcloc" 0) + => (lambda (args) + (generate-procedure-source-information #f) + (loop args))] [(get-opt args "--unsafe" 0) => (lambda (args) (optimize-level 3) @@ -86,6 +114,10 @@ => (lambda (args) (set! build-dir (car args)) (loop (cdr args)))] + [(get-opt args "--xpatch" 1) + => (lambda (args) + (set! xpatch-path (car args)) + (loop (cdr args)))] [(null? args) (error 'compile-file "missing source file")] [else @@ -105,6 +137,9 @@ src-so (string-append build-dir src-so))) +(when xpatch-path + (load xpatch-path)) + (cond [whole-program? (unless (= 1 (length deps)) @@ -122,4 +157,24 @@ [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))]) + (cond + [xpatch-path + ;; Cross compile: use `compile-to-file` to get a second, host-format output file + (let ([sfd (let ([i (open-file-input-port src)]) + (make-source-file-descriptor src i #t))]) + (let ([exprs (call-with-input-file + src + (lambda (i) + (let loop ([pos 0]) + (let-values ([(e pos) (get-datum/annotations i sfd pos)]) + (if (eof-object? e) + '() + ;; Strip enough of the annotation to expose 'library + ;; or 'top-level-program: + (let ([e (map annotation-expression + (annotation-expression e))]) + (cons e (loop pos))))))))]) + (compile-to-file exprs dest)))] + [else + ;; Normal mode + (compile-file src dest)]))]) diff -Nru racket-7.2+ppa2/src/cs/demo/control.ss racket-7.3+ppa1/src/cs/demo/control.ss --- racket-7.2+ppa2/src/cs/demo/control.ss 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/src/cs/demo/control.ss 2019-05-16 01:29:07.000000000 +0000 @@ -431,11 +431,13 @@ ;; ---------------------------------------- ;; Engines -(define e (make-engine (lambda () 'done) #f #f)) +(define engine-tag (default-continuation-prompt-tag)) + +(define e (make-engine (lambda () 'done) engine-tag #f #f)) (check (cdr (e 100 void list vector)) '(done)) -(define e-forever (make-engine (lambda () (let loop () (loop))) #f #f)) +(define e-forever (make-engine (lambda () (let loop () (loop))) engine-tag #f #f)) (check (vector? (e-forever 10 void list vector)) #t) @@ -448,6 +450,7 @@ [else (engine-block) (loop (sub1 n))]))) + engine-tag #f #f)) (check (let ([started 0]) (let loop ([e e-10] [n 0]) @@ -472,6 +475,7 @@ (lambda () (set! pre (add1 pre))) (lambda () (loop (sub1 n))) (lambda () (set! post (add1 post))))]))) + engine-tag #f #f)]) (check (let loop ([e e-10/dw] [n 0]) (e 200 @@ -493,10 +497,10 @@ (thread-cell-set! pt (add1 p-old)) (list u-old p-old - (make-engine gen #f #f) + (make-engine gen engine-tag #f #f) (thread-cell-ref ut) (thread-cell-ref pt))) - (define l1 ((make-engine gen #f #f) + (define l1 ((make-engine gen engine-tag #f #f) 100 void (lambda (remain l) l) @@ -522,7 +526,7 @@ (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))]) + (make-engine (lambda () (|#%app| my-param)) engine-tag #f #f))]) (check (|#%app| my-param) 'init) (check (e 1000 void (lambda (remain v) v) (lambda (e) (error 'engine "oops"))) 'set)) @@ -618,6 +622,7 @@ (loop (sub1 n))))) (lambda () (set! post (add1 post)))))))) + engine-tag #f #f)) (check (let ([prefixes 0]) diff -Nru racket-7.2+ppa2/src/cs/demo/thread.ss racket-7.3+ppa1/src/cs/demo/thread.ss --- racket-7.2+ppa2/src/cs/demo/thread.ss 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/src/cs/demo/thread.ss 2019-05-16 01:29:07.000000000 +0000 @@ -132,6 +132,29 @@ (check tdelay (sync tdelay)) (printf "[That break was from a thread, and it's expected]\n") (check #t (>= (current-inexact-milliseconds) (+ now3 0.1))) + + (define got-here? #f) + (define break-self (thread (lambda () + (unsafe-start-atomic) + (break-thread (current-thread)) + (unsafe-end-atomic) + (set! got-here? #t)))) + (check break-self (sync break-self)) + (printf "[That break was from a thread, and it's expected]\n") + (check #f got-here?) + + (define break-self-immediate (thread (lambda () + (dynamic-wind + void + (lambda () + (unsafe-start-breakable-atomic) + (break-thread (current-thread)) + (set! got-here? #t)) + (lambda () + (unsafe-end-atomic)))))) + (check break-self-immediate (sync break-self-immediate)) + (printf "[That break was from a thread, and it's expected]\n") + (check #f got-here?) ;; Make sure breaks are disabled in a `dynamic-wind` post thunk (define dw-s (make-semaphore)) diff -Nru racket-7.2+ppa2/src/cs/expander.sls racket-7.3+ppa1/src/cs/expander.sls --- racket-7.2+ppa2/src/cs/expander.sls 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/src/cs/expander.sls 2019-05-16 01:29:07.000000000 +0000 @@ -28,7 +28,9 @@ (thread) (regexp) (io) - (linklet)) + (linklet) + (only (schemify) + force-unfasl)) (include "place-register.ss") (define-place-register-define define expander-register-start expander-register-count) @@ -38,9 +40,6 @@ ;; the build incompatible with previously generated ".zo" files. (define compile-as-independent? #f) - (define (fasl->s-exp/intern s) - (1/fasl->s-exp/intern s)) - ;; The expander needs various tables to set up primitive modules, and ;; the `primitive-table` function is the bridge between worlds @@ -113,7 +112,9 @@ (thread) (io) (regexp) - (linklet))) + (linklet) + (only (schemify) + force-unfasl))) ;; Ensure that the library is visited, especially for a wpo build: (eval 'variable-set!))) @@ -181,9 +182,6 @@ [(_ name val) #`(let ([name val]) name)]))) (eval `(define raise-binding-result-arity-error ',raise-binding-result-arity-error))) - ;; Special "primitive" for syntax-data deserialization: - (eval `(define fasl->s-exp/intern ',fasl->s-exp/intern)) - ;; For interpretation of the outer shell of a linklet: (install-linklet-primitive-tables! kernel-table unsafe-table @@ -208,7 +206,11 @@ ;; 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))))) + (and (1/string->number str 10 'read) + ;; Special case: `#%` is never read as a number or error: + (not (and (>= (string-length str) 2) + (eqv? (string-ref str 0) #\#) + (eqv? (string-ref str 1) #\%)))))) ;; `set-maybe-raise-missing-module!` is also from the `io` library (set-maybe-raise-missing-module! maybe-raise-missing-module)) diff -Nru racket-7.2+ppa2/src/cs/.gitignore racket-7.3+ppa1/src/cs/.gitignore --- racket-7.2+ppa2/src/cs/.gitignore 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/src/cs/.gitignore 2019-05-16 01:29:07.000000000 +0000 @@ -1,2 +1,4 @@ *.so *.wpo +*.ta6osx +*.ta6le diff -Nru racket-7.2+ppa2/src/cs/io.sls racket-7.3+ppa1/src/cs/io.sls --- racket-7.2+ppa2/src/cs/io.sls 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/src/cs/io.sls 2019-05-16 01:29:07.000000000 +0000 @@ -359,7 +359,7 @@ 'rktio_get_ctl_c_handler rktio_get_ctl_c_handler] form ...)])) (include "../rktio/rktio.rktl")))) - + ;; ---------------------------------------- (define format @@ -469,5 +469,5 @@ (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) + (set-make-async-callback-poll-wakeup! unsafe-make-signal-received) (set-get-machine-info! get-machine-info)) diff -Nru racket-7.2+ppa2/src/cs/linklet/annotation.ss racket-7.3+ppa1/src/cs/linklet/annotation.ss --- racket-7.2+ppa2/src/cs/linklet/annotation.ss 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/src/cs/linklet/annotation.ss 2019-05-16 01:29:07.000000000 +0000 @@ -28,13 +28,20 @@ [else (values (cons a d) (cons stripped-a stripped-d))]))] [(correlated? v) (let-values ([(e stripped-e) (correlated->annotation* (correlated-e v))]) - (let ([name (correlated-property v 'inferred-name)]) + (let ([name (correlated-property v 'inferred-name)] + [method-arity-error (correlated-property v 'method-arity-error)]) (define (add-name e) (if (and name (not (void? name))) `(|#%name| ,name ,e) e)) - (values (add-name (transfer-srcloc v e stripped-e)) - (add-name stripped-e))))] + (define (add-method-arity-error e) + (if method-arity-error + `(|#%method-arity| ,e) + e)) + (values (add-method-arity-error + (add-name (transfer-srcloc v e stripped-e))) + (add-method-arity-error + (add-name stripped-e)))))] ;; correlated will be nested only in pairs with current expander [else (values v v)])) diff -Nru racket-7.2+ppa2/src/cs/linklet/check.ss racket-7.3+ppa1/src/cs/linklet/check.ss --- racket-7.2+ppa2/src/cs/linklet/check.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/src/cs/linklet/check.ss 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,42 @@ +(define (check-compile-args who import-keys get-import orig-options) + (unless (or (not import-keys) (vector? import-keys)) + (raise-argument-error who "(or/c #f vector?)" import-keys)) + (unless (or (not get-import) + (and (procedure? get-import) (procedure-arity-includes? get-import 1))) + (raise-argument-error who "(or/c (procedure-arity-includes/c 1) #f)" get-import)) + (when (and get-import (not import-keys)) + (raise-arguments-error who + (string-append + "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" get-import)) + (let loop ([options orig-options] + [redundant #f] + [serializable #f] + [unsafe #f] + [static #f] + [use-prompt #f] + [uninterned-literal #f]) + (cond + [(null? options) + (when redundant + (raise-arguments-error who "redundant option" + "redundant option" redundant + "supplied options" orig-options))] + [(pair? options) + (case (car options) + [(serializable) + (loop (cdr options) (or redundant serializable) 'serializable unsafe static use-prompt uninterned-literal)] + [(unsafe) + (loop (cdr options) (or redundant unsafe) serializable 'unsafe static use-prompt uninterned-literal)] + [(static) + (loop (cdr options) (or redundant static) serializable unsafe 'static use-prompt uninterned-literal)] + [(use-prompt) + (loop (cdr options) (or redundant use-prompt) serializable unsafe static 'use-prompt uninterned-literal)] + [(uninterned-literal) + (loop (cdr options) (or redundant uninterned-literal) serializable unsafe static use-prompt 'uninterned-literal)] + [else + (loop #f redundant serializable unsafe static use-prompt uninterned-literal)])] + [else + (raise-argument-error who "(listof/c 'serializable 'unsafe 'static 'use-prompt 'uninterned-literal)" + orig-options)]))) diff -Nru racket-7.2+ppa2/src/cs/linklet/cross-compile.ss racket-7.3+ppa1/src/cs/linklet/cross-compile.ss --- racket-7.2+ppa2/src/cs/linklet/cross-compile.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/src/cs/linklet/cross-compile.ss 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,171 @@ +;; The server half of this interaction is in "../c/cross-serve.ss". + +;; Currently, cross-compilation support in Chez Scheme replaces the +;; compiler for the build machine. Until that changes, we can't load +;; cross-compilation support into the Chez Scheme instance that runs +;; Racket. Instead, launch a separate process and commuincate with +;; it via stdin/stdout. + +;; To manage the possibility of multipe Racket threads and places that +;; cross-compile at the same time, we create a separate cross-compiler +;; process for each request --- but cache processes so that requests +;; can complete quickly in common cases. These separate processes can +;; just be forgotten if the compilation request is abandoned, so we +;; put each compiler in a thread (managed by the root custodian) that +;; can be cleaned up. + +;; List of (list ) +(define cross-machine-types '()) + +(define (add-cross-compiler! x-machine-type x-path exe-path) + (set! cross-machine-types + (cons (list x-machine-type (cons exe-path x-path)) + cross-machine-types))) + +;; List of (list ) +;; representing started compiler processes. +(define cross-machine-compiler-cache (unsafe-make-place-local '())) + +;; To clean up abandonded compilers: +(define compiler-will-executor (unsafe-make-place-local #f)) + +;; Find compiler, starting one if necessary +(define (find-cross who machine) + (disable-interrupts) + (let* ([cache (unsafe-place-local-ref cross-machine-compiler-cache)] + [a (#%assq machine cache)]) + (cond + [a + (unsafe-place-local-set! cross-machine-compiler-cache (#%remq a cache)) + (enable-interrupts) + a] + [else + (enable-interrupts) + (let ([a (#%assq machine cross-machine-types)]) + (cond + [a (start-cross-compiler machine (cadr a))] + [else + (#%error who "no compiler loaded for ~a" machine)]))]))) + +(define (cache-cross-compiler a) + (with-interrupts-disabled + (unsafe-place-local-set! cross-machine-compiler-cache + (cons a (unsafe-place-local-ref cross-machine-compiler-cache))))) + +(define (do-cross cmd machine v) + (let* ([a (find-cross 'cross-compile machine)] + [ch (cadr a)] + [reply-ch (make-channel)]) + (channel-put ch (list cmd + v + reply-ch)) + (begin0 + (channel-get reply-ch) + (cache-cross-compiler a)))) + +(define (cross-compile machine v) + (do-cross 'c machine v)) + +(define (cross-fasl-to-string machine v) + (do-cross 'f machine v)) + +;; Start a compiler as a Racket thread under the root custodian. +;; Using Racket's scheduler lets us use the event and I/O system, +;; including support for running a process and managing resources +;; through a custodian. Putting each cross-compiler instance in +;; its own thread more gracefully handles the case that a compilation +;; request is abandoned by the caller. +(define (start-cross-compiler machine exe+x) + (let ([we (with-interrupts-disabled + (or (unsafe-place-local-ref compiler-will-executor) + (let ([we (make-will-executor)]) + (unsafe-place-local-set! compiler-will-executor we) + we)))]) + (let clean-up () + (when (will-try-execute we) + (clean-up))) + (let ([exe (find-exe (car exe+x))] + [xpatch-dir (cdr exe+x)] + [msg-ch (make-channel)] + [c (unsafe-make-custodian-at-root)]) + (with-continuation-mark + parameterization-key + (extend-parameterization (continuation-mark-set-first + #f + parameterization-key) + current-custodian + c) + ;; At this point, we're under the root custodian + (thread + (lambda () + (define (patchfile base) + (build-path xpatch-dir (string-append base "-xpatch." (symbol->string machine)))) + (let-values ([(subproc from to err) + (subprocess #f #f (get-original-error-port) + exe + "--cross-server" + (symbol->string machine) + (patchfile "compile") + (patchfile "library"))]) + ;; If this compiler instance becomes unreachable because the + ;; called is interrupted, then shut this compiler down: + (will-register we msg-ch (lambda (msg-ch) (custodian-shutdown-all c))) + (let loop () + (let ([msg (channel-get msg-ch)]) + ;; msg is (list ) + (write-string (#%format "~a\n" (car msg)) to) + (let ([bv (fasl-to-bytevector (cadr msg))]) + (write-bytes (integer->integer-bytes (bytevector-length bv) 8 #f #f) to) + (write-bytes bv to)) + (flush-output to) + (let* ([len-bstr (read-bytes 8 from)] + [len (integer-bytes->integer len-bstr #f #f)] + [bv (read-bytes len from)]) + (channel-put (caddr msg) bv)) + (loop))))))) + (list machine msg-ch)))) + +(define (fasl-to-bytevector v) + (let-values ([(o get) (open-bytevector-output-port)]) + (fasl-write* v o) + (get))) + +(define (find-exe exe) + (let-values ([(base name dir?) (split-path exe)]) + (cond + [(eq? base 'relative) + (let loop ([paths (get-exe-search-path)]) + (cond + [(null? paths) exe] + [else + (let ([f (build-path (car paths) exe)]) + (if (file-exists? f) + f + (loop (cdr paths))))]))] + [else + (path->complete-path exe (find-system-path 'orig-dir))]))) + +(define (get-exe-search-path) + (define (accum->path one-accum) + (bytes->path (u8-list->bytevector (reverse one-accum)))) + (let ([path (environment-variables-ref + (|#%app| current-environment-variables) + (string->utf8 "PATH"))]) + (cond + [(not path) '()] + [else + (let loop ([bytes (bytevector->u8-list path)] [one-accum '()] [accum '()]) + (cond + [(null? bytes) (let ([accum (if (null? one-accum) + accum + (cons (accum->path one-accum) + accum))]) + (reverse accum))] + [(eqv? (car bytes) (if (eq? 'windows (system-type)) + (char->integer #\;) + (char->integer #\:))) + (if (null? one-accum) + (loop (cdr bytes) '() accum) + (loop (cdr bytes) '() (cons (accum->path one-accum) accum)))] + [else + (loop (cdr bytes) (cons (car bytes) one-accum) accum)]))]))) diff -Nru racket-7.2+ppa2/src/cs/linklet/performance.ss racket-7.3+ppa1/src/cs/linklet/performance.ss --- racket-7.2+ppa2/src/cs/linklet/performance.ss 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/src/cs/linklet/performance.ss 2019-05-16 01:29:07.000000000 +0000 @@ -6,6 +6,8 @@ (define current-start-time '()) (define current-gc-start-time '()) +(define performance-thread-id (get-thread-id)) + ;; List keys for passes related to register allocation as recorded by ;; Chez Scheme and reported from `$pass-stats`: (define register-allocation-passes @@ -37,7 +39,8 @@ (define (measure-performance-region label thunk) (cond - [measure-performance? + [(and measure-performance? + (eqv? (get-thread-id) performance-thread-id)) (with-interrupts-disabled (set! current-start-time (cons (current-process-milliseconds) current-start-time)) (set! current-gc-start-time (cons (current-gc-milliseconds) current-gc-start-time))) diff -Nru racket-7.2+ppa2/src/cs/linklet/read.ss racket-7.3+ppa1/src/cs/linklet/read.ss --- racket-7.2+ppa2/src/cs/linklet/read.ss 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/src/cs/linklet/read.ss 2019-05-16 01:29:07.000000000 +0000 @@ -4,7 +4,7 @@ 'read-linklet (let* ([len (integer-bytes->integer (read-bytes 4 in) #f #f)] [bstr (read-bytes len in)]) - (adjust-linklet-bundle-laziness + (adjust-linklet-bundle-laziness-and-paths (fasl-read (open-bytevector-input-port bstr)))))) (define read-on-demand-source @@ -17,7 +17,7 @@ v)) v))) -(define (adjust-linklet-bundle-laziness ht) +(define (adjust-linklet-bundle-laziness-and-paths ht) (let loop ([i (hash-iterate-first ht)]) (cond [(not i) (hasheq)] @@ -26,7 +26,8 @@ (hash-set (loop (hash-iterate-next ht i)) key (if (linklet? val) - (adjust-linklet-laziness val) + (adjust-linklet-laziness + (decode-linklet-paths val)) val)))]))) (define (adjust-linklet-laziness linklet) @@ -36,3 +37,10 @@ 'faslable 'faslable-strict))) +(define (decode-linklet-paths linklet) + (let ([paths (linklet-paths linklet)]) + (cond + [(null? paths) + linklet] + [else + (set-linklet-paths linklet (map compiled-path->path paths))]))) diff -Nru racket-7.2+ppa2/src/cs/linklet/write.ss racket-7.3+ppa1/src/cs/linklet/write.ss --- racket-7.2+ppa2/src/cs/linklet/write.ss 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/src/cs/linklet/write.ss 2019-05-16 01:29:07.000000000 +0000 @@ -4,8 +4,44 @@ #vu8(99 104 101 122 45 115 99 104 101 109 101)) (define (write-linklet-bundle-hash ht dest-o) - (let-values ([(o get) (open-bytevector-output-port)]) - (fasl-write* ht o) - (let ([bstr (get)]) + (let-values ([(ht cross-machine) (encode-linklet-paths ht)]) + (let ([bstr (if cross-machine + (cross-fasl-to-string cross-machine ht) + (let-values ([(o get) (open-bytevector-output-port)]) + (fasl-write* ht o) + (get)))]) (write-bytes (integer->integer-bytes (bytes-length bstr) 4 #f #f) dest-o) (write-bytes bstr dest-o)))) + +(define (encode-linklet-paths orig-ht) + (let ([path->compiled-path (make-path->compiled-path 'write-linklet)]) + (let loop ([i (hash-iterate-first orig-ht)] [ht orig-ht] [cross-machine #f]) + (cond + [(not i) (values ht cross-machine)] + [else + (let-values ([(key v) (hash-iterate-key+value orig-ht i)]) + (let ([new-v (if (and (linklet? v) + (pair? (linklet-paths v))) + (adjust-cross-perparation + (set-linklet-paths + v + (map path->compiled-path + (linklet-paths v)))) + v)]) + (when (linklet? new-v) + (linklet-pack-exports-info! new-v)) + (let ([new-ht (if (eq? v new-v) + ht + (hash-set ht key new-v))]) + (loop (hash-iterate-next orig-ht i) + new-ht + (or cross-machine + (and (linklet? v) + (let ([prep (linklet-preparation v)]) + (and (pair? prep) (cdr prep)))))))))])))) + +;; Before fasl conversion, change 'cross to 'faslable +(define (adjust-cross-perparation l) + (if (pair? (linklet-preparation l)) + (set-linklet-preparation l 'faslable) + l)) diff -Nru racket-7.2+ppa2/src/cs/linklet.sls racket-7.3+ppa1/src/cs/linklet.sls --- racket-7.2+ppa2/src/cs/linklet.sls 2019-02-02 22:11:53.000000000 +0000 +++ racket-7.3+ppa1/src/cs/linklet.sls 2019-05-16 01:29:07.000000000 +0000 @@ -29,6 +29,8 @@ variable-reference-constant? variable-reference-from-unsafe? + add-cross-compiler! ; not exported to racket + compile-enforce-module-constants compile-context-preservation-enabled compile-allow-set!-undefined @@ -84,9 +86,30 @@ current-environment-variables find-system-path build-path - format) + format + ;; Used by cross-compiler: + get-original-error-port + subprocess + write-string + write-bytes + flush-output + read-bytes + split-path + path->complete-path + file-exists?) (only (thread) - current-process-milliseconds) + current-process-milliseconds + ;; Used by cross-compiler: + unsafe-make-custodian-at-root + current-custodian + custodian-shutdown-all + thread + make-channel + channel-put + channel-get + make-will-executor + will-register + will-try-execute) (regexp) (schemify)) @@ -146,6 +169,7 @@ (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 cp0-on? (getenv "PLT_LINKLET_SHOW_CP0")) (define show-on? (or gensym-on? pre-jit-on? pre-lift-on? @@ -153,6 +177,7 @@ post-interp-on? jit-demand-on? known-on? + cp0-on? (getenv "PLT_LINKLET_SHOW"))) (define show (case-lambda @@ -169,6 +194,7 @@ (correlated->annotation v)))))))) v])) + (include "linklet/check.ss") (include "linklet/version.ss") (include "linklet/write.ss") (include "linklet/read.ss") @@ -200,18 +226,21 @@ (hash-for-each table (lambda (k v) (hash-set! primitives k v)))) tables)) - (define (outer-eval s format) + (define (outer-eval s paths format) (if (eq? format 'interpret) - (interpret-linklet s primitives variable-ref variable-ref/no-check variable-set! + (interpret-linklet s paths primitives variable-ref variable-ref/no-check variable-set! make-arity-wrapper-procedure) - (compile* s))) + (let ([proc (compile* s)]) + (if (null? paths) + proc + (#%apply proc paths))))) (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) + (define (compile-to-bytevector s paths format) (let ([bv (cond [(eq? format 'interpret) (let-values ([(o get) (open-bytevector-output-port)]) @@ -222,7 +251,16 @@ (bytevector-compress bv) bv))) - (define (eval-from-bytevector c-bv format) + (define (make-cross-compile-to-bytevector machine) + (lambda (s paths format) + (let ([bv (cond + [(eq? format 'interpret) (cross-fasl-to-string machine s)] + [else (cross-compile machine s)])]) + (if compress-code? + (bytevector-compress bv) + bv)))) + + (define (eval-from-bytevector c-bv paths format) (let ([bv (if (bytevector-uncompressed-fasl? c-bv) c-bv (begin @@ -238,11 +276,14 @@ (fasl-read (open-bytevector-input-port bv)))]) (performance-region 'outer - (outer-eval r format)))] + (outer-eval r paths format)))] [else - (performance-region - 'faslin-code - (code-from-bytevector bv))]))) + (let ([proc (performance-region + 'faslin-code + (code-from-bytevector bv))]) + (if (null? paths) + proc + (#%apply proc paths)))]))) (define (code-from-bytevector bv) (let ([i (open-bytevector-input-port bv)]) @@ -285,7 +326,7 @@ [else ;; Combine an annotation with a hash code in a vector (let-values ([(o get) (open-bytevector-output-port)]) - (fasl-write (cons (version) a) o) + (fasl-write* (cons (version) a) o) (vector (sha1-bytes (get)) a))])) (define-record-type wrapped-code @@ -317,13 +358,13 @@ [code (lookup-code hash)]) (cond [code - (let* ([f (eval-from-bytevector code 'compile)]) + (let* ([f (eval-from-bytevector code '() 'compile)]) (wrapped-code-content-set! wc f) f)] [else - (let ([code (compile-to-bytevector (vector-ref f 1) 'compile)]) + (let ([code (compile-to-bytevector (vector-ref f 1) '() 'compile)]) (insert-code hash code) - (let* ([f (eval-from-bytevector code 'compile)]) + (let* ([f (eval-from-bytevector code '() 'compile)]) (wrapped-code-content-set! wc f) f))]))] [else @@ -379,21 +420,25 @@ ;; 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 + ;; A linklet also has a table of information about its exports. That + ;; known-value information is used by schemify to perform + ;; cross-linklet inlining and related optimizations. (define-record-type linklet - (fields (mutable code) ; the procedure + (fields (mutable code) ; the procedure or interpretable form + paths ; list of paths; if non-empty, `code` expects them as arguments format ; 'compile or 'interpret (where the latter may have compiled internal parts) - (mutable preparation) ; 'faslable, 'faslable-strict, 'callable, or 'lazy + (mutable preparation) ; 'faslable, 'faslable-strict, 'callable, 'lazy, or (cons 'cross ) importss-abi ; ABI for each import, in parallel to `importss` - exports-info ; hash(sym -> known) for info about each export; see "known.rkt" + (mutable exports-info) ; hash(sym -> known) for info about export; see "known.rkt"; unfasl on demand name ; name of the linklet (for debugging purposes) importss ; list of list of import symbols - exports) ; list of export symbols - (nongenerative #{linklet Zuquy0g9bh5vmeespyap4g-0})) + exports) ; list of export symbol-or-pair, pair is (cons export-symbol src-symbol) + (nongenerative #{linklet Zuquy0g9bh5vmeespyap4g-2})) (define (set-linklet-code linklet code preparation) (make-linklet code + (linklet-paths linklet) (linklet-format linklet) preparation (linklet-importss-abi linklet) @@ -402,15 +447,66 @@ (linklet-importss linklet) (linklet-exports linklet))) + (define (set-linklet-paths linklet paths) + (make-linklet (linklet-code linklet) + paths + (linklet-format linklet) + (linklet-preparation linklet) + (linklet-importss-abi linklet) + (linklet-exports-info linklet) + (linklet-name linklet) + (linklet-importss linklet) + (linklet-exports linklet))) + + (define (set-linklet-preparation linklet preparation) + (make-linklet (linklet-code linklet) + (linklet-paths linklet) + (linklet-format linklet) + preparation + (linklet-importss-abi linklet) + (linklet-exports-info linklet) + (linklet-name linklet) + (linklet-importss linklet) + (linklet-exports linklet))) + + (define (linklet-pack-exports-info! l) + (let ([info (linklet-exports-info l)]) + (when (hash? info) + (let ([new-info + (cond + [(zero? (hash-count info)) #f] + [else + (let-values ([(o get) (open-bytevector-output-port)]) + ;; convert to a hashtable so the fasled form is compact and + ;; doesn't have hash codes: + (fasl-write* (hash->eq-hashtable (hash-copy info)) o) + (get))])]) + (linklet-exports-info-set! l new-info))))) + + (define (linklet-unpack-exports-info! l) + (let ([info (linklet-exports-info l)]) + (unless (hash? info) + (let ([new-info + (cond + [(not info) (hasheq)] + [else + (eq-hashtable->hash (fasl-read (open-bytevector-input-port info)))])]) + (linklet-exports-info-set! l new-info))))) + (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) (compile-linklet c #f #f #f '(serializable))] + [(c name) (compile-linklet c name #f #f '(serializable))] + [(c name import-keys) (compile-linklet c name import-keys #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 check-result (check-compile-args 'compile-linklet import-keys get-import options)) (define serializable? (#%memq 'serializable options)) (define use-prompt? (#%memq 'use-prompt options)) + (define cross-machine (and serializable? + (let ([m (|#%app| current-compile-target-machine)]) + (and (not (eq? m (machine-type))) + m)))) (performance-region 'schemify (define jitify-mode? @@ -431,8 +527,10 @@ prim-knowns ;; Callback to get a specific linklet for a ;; given import: - (lambda (key) - (lookup-linklet-or-instance get-import key)) + (if get-import + (lambda (key) (values #f #f #f)) + (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))) @@ -468,31 +566,45 @@ (lambda (expr arity-mask name) (performance-region 'compile-nested - (let ([code ((if serializable? compile*-to-bytevector compile*) + (let ([code ((if serializable? + (if cross-machine + (lambda (s) (cross-compile cross-machine s)) + compile*-to-bytevector) + compile*) (show lambda-on? "lambda" (correlated->annotation expr)))]) (if serializable? (make-wrapped-code code arity-mask name) code))))])))])) + (define-values (paths impl-lam/paths) + (if serializable? + (extract-paths-from-schemified-linklet impl-lam/jitified (not jitify-mode?)) + (values '() impl-lam/jitified))) (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)])]) + [(mach) (show post-lambda-on? "post-lambda" impl-lam/paths)] + [else (show "schemified" impl-lam/paths)])]) (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))))) + (when (and cp0-on? (not jitify-mode?)) + (show "cp0" (#%expand/optimize (correlated->annotation impl-lam/paths)))) (performance-region 'compile-linklet ;; 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))) + (let ([lk (make-linklet ((if serializable? + (if cross-machine + (make-cross-compile-to-bytevector cross-machine) + compile-to-bytevector) + outer-eval) + (show (and jitify-mode? post-interp-on?) "post-interp" impl-lam/interpable) + paths + format) + paths format - (if serializable? 'faslable 'callable) + (if serializable? (if cross-machine (cons 'cross cross-machine) 'faslable) 'callable) importss-abi exports-info name @@ -515,6 +627,7 @@ (let-values ([(lnk/inst more-import-keys) (get-import key)]) (cond [(linklet? lnk/inst) + (linklet-unpack-exports-info! lnk/inst) (values (linklet-exports-info lnk/inst) ;; No conversion needed: #f @@ -526,8 +639,20 @@ [else (values #f #f #f)]))] [else (values #f #f #f)])) - (define (recompile-linklet lnk . args) lnk) - + (define recompile-linklet + (case-lambda + [(lnk) (recompile-linklet lnk #f #f #f '(serializable))] + [(lnk name) (recompile-linklet lnk name #f #f '(serializable))] + [(lnk name import-keys) (recompile-linklet lnk name import-keys #f '(serializable))] + [(lnk name import-keys get-import) (recompile-linklet lnk name import-keys get-import '(serializable))] + [(lnk name import-keys get-import options) + (unless (linklet? lnk) + (raise-argument-error 'recompile-linklet "linklet?" lnk)) + (check-compile-args 'recompile-linklet import-keys get-import options) + (if import-keys + (values lnk import-keys) + lnk)])) + ;; Intended to speed up reuse of a linklet in exchange for not being ;; able to serialize anymore (define (eval-linklet linklet) @@ -535,7 +660,9 @@ [(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)] + (set-linklet-code linklet + (eval-from-bytevector (linklet-code linklet) (linklet-paths linklet) (linklet-format linklet)) + 'callable)] [else linklet])) @@ -555,7 +682,7 @@ (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))]) + (let ([code (eval-from-bytevector (linklet-code linklet) (linklet-paths linklet) (linklet-format linklet))]) (with-interrupts-disabled (when (eq? 'lazy (linklet-preparation linklet)) (linklet-code-set! linklet code) @@ -563,18 +690,25 @@ ;; 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 (make-extract-variables target-instance) - import-instances - (linklet-importss linklet) - (linklet-importss-abi linklet))) - (create-variables target-instance - (linklet-exports linklet)))))))] + ((if use-prompt? + ;; For per-form prompts with in a module linklet, + ;; rely on 'use-prompt provided at compile time. + ;; But this one is useful for top-level forms. + call-with-module-prompt + (lambda (thunk) (thunk))) + (lambda () + (apply + (if (eq? 'callable (linklet-preparation linklet)) + (linklet-code linklet) + (eval-from-bytevector (linklet-code linklet) (linklet-paths linklet) (linklet-format linklet))) + (make-variable-reference target-instance #f) + (append (apply append + (map (make-extract-variables target-instance) + 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))]) @@ -585,7 +719,7 @@ (linklet-importss linklet)) (define (linklet-export-variables linklet) - (linklet-exports linklet)) + (map (lambda (e) (if (pair? e) (car e) e)) (linklet-exports linklet))) ;; ---------------------------------------- @@ -596,6 +730,7 @@ (define-record variable (val name + source-name constance ; #f (mutable), 'constant, or 'consistent (always the same shape) inst-box)) ; weak pair with instance in `car` @@ -604,7 +739,7 @@ (define variable-undefined (gensym 'undefined)) (define (make-internal-variable name) - (make-variable variable-undefined name #f (cons #!bwp #f))) + (make-variable variable-undefined name name #f (cons #!bwp #f))) (define (do-variable-set! var val constance as-define?) (cond @@ -616,7 +751,7 @@ exn:fail:contract:variable (string-append "define-values: assignment disallowed;\n" " cannot re-define a constant\n" - " constant: " (symbol->string (variable-name var)) "\n" + " constant: " (symbol->string (variable-source-name var)) "\n" " in module:" (variable-module-name var)) (current-continuation-marks) (variable-name var)))] @@ -624,7 +759,7 @@ (raise (|#%app| exn:fail:contract:variable - (string-append (symbol->string (variable-name var)) + (string-append (symbol->string (variable-source-name var)) ": cannot modify constant") (current-continuation-marks) (variable-name var)))])] @@ -693,25 +828,29 @@ [set? (string-append "set!: assignment disallowed;\n" " cannot set variable before its definition\n" - " variable: " (symbol->string (variable-name var)) + " variable: " (symbol->string (variable-source-name var)) (identify-module var))] [else - (string-append (symbol->string (variable-name var)) + (string-append (symbol->string (variable-source-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) + (define (create-variables inst syms-or-pairs) (let ([ht (instance-hash inst)] [inst-box (weak-cons inst #f)]) - (map (lambda (sym) - (or (hash-ref ht sym #f) - (let ([var (make-variable variable-undefined sym #f inst-box)]) - (hash-set! ht sym var) - var))) - syms))) + (map (lambda (sym-or-pair) + (let-values ([(sym src-sym) + (if (pair? sym-or-pair) + (values (car sym-or-pair) (cdr sym-or-pair)) + (values sym-or-pair sym-or-pair))]) + (or (hash-ref ht sym #f) + (let ([var (make-variable variable-undefined sym src-sym #f inst-box)]) + (hash-set! ht sym var) + var)))) + syms-or-pairs))) (define (variable->known var) (let ([desc (cdr (variable-inst-box var))]) @@ -780,7 +919,8 @@ (cond [(null? content) (void)] [else - (hash-set! ht (car content) (make-variable (cadr content) (car content) constance inst-box)) + (let ([name (car content)]) + (hash-set! ht (car content) (make-variable (cadr content) name name constance inst-box))) (loop (cddr content))])) inst)])) @@ -816,7 +956,7 @@ (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 variable-undefined k #f (weak-cons i #f))]) + (let ([var (make-variable variable-undefined k k #f (weak-cons i #f))]) (hash-set! (instance-hash i) k var) var))]) (variable-set! var v mode))])) @@ -930,6 +1070,8 @@ (loop (cdr vars) (cdr syms))))])) ;; -------------------------------------------------- + + (include "linklet/cross-compile.ss") (define compile-enforce-module-constants (make-parameter #t (lambda (v) (and v #t)))) @@ -953,7 +1095,9 @@ (define (compile-target-machine? v) (unless (symbol? v) (raise-argument-error 'compile-target-machine? "symbol?" v)) - (eq? v (machine-type))) + (or (eq? v (machine-type)) + (and (#%assq v cross-machine-types) + #t))) (define eval-jit-enabled (make-parameter #t (lambda (v) (and v #t)))) @@ -994,4 +1138,5 @@ (set-foreign-eval! eval/foreign) + (enable-arithmetic-left-associative #t) (expand-omit-library-invocations #t)) diff -Nru racket-7.2+ppa2/src/cs/main/help.ss racket-7.3+ppa1/src/cs/main/help.ss --- racket-7.2+ppa2/src/cs/main/help.ss 1970-01-01 00:00:00.000000000 +0000 +++ racket-7.3+ppa1/src/cs/main/help.ss 2019-05-16 01:29:07.000000000 +0000 @@ -0,0 +1,90 @@ +(define (show-help) + (define init-filename + (let-values ([(base name dir?) (split-path (find-system-path 'init-file))]) + (path->string name))) + (#%printf "~a: [