diff --git a/collects/2htdp/image.ss b/collects/2htdp/image.ss index eeb3fb0d4c..bf2612ed7d 100644 --- a/collects/2htdp/image.ss +++ b/collects/2htdp/image.ss @@ -52,6 +52,9 @@ and they all have good sample contracts. (It is amazing what we can do with kids (provide overlay overlay/align overlay/xy + underlay + underlay/align + underlay/xy beside beside/align diff --git a/collects/2htdp/private/image-more.ss b/collects/2htdp/private/image-more.ss index aa8142316f..7b0e94034e 100644 --- a/collects/2htdp/private/image-more.ss +++ b/collects/2htdp/private/image-more.ss @@ -307,10 +307,14 @@ ;; overlay : image image image ... -> image ;; places images on top of each other with their upper left corners aligned. last one goes on the bottom - (define/chk (overlay image image2 . image3) (overlay/internal 'left 'top image (cons image2 image3))) +;; underlay : image image image ... -> image +(define (underlay image image2 . image3) + (let ([imgs (reverse (list* image image2 image3))]) + (overlay/internal 'left 'top (car imgs) (cdr imgs)))) + ;; overlay/align : string string image image image ... -> image ;; the first string has to be one of "center" "middle" "left" or "right" (or symbols) ;; the second string has to be one of "center" "middle" "top" "bottom" or "baseline" (or symbols) @@ -322,6 +326,10 @@ (define/chk (overlay/align x-place y-place image image2 . image3) (overlay/internal x-place y-place image (cons image2 image3))) +(define/chk (underlay/align x-place y-place image image2 . image3) + (let ([imgs (reverse (list* image image2 image3))]) + (overlay/internal x-place y-place (car imgs) (cdr imgs)))) + (define (overlay/internal x-place y-place fst rst) (let loop ([fst fst] [rst rst]) @@ -346,14 +354,16 @@ (case x-place [(left) 0] [(middle) (/ (image-right image) 2)] - [(right) (image-right image)])) + [(right) (image-right image)] + [else (error 'find-x-spot "~s" x-place)])) (define (find-y-spot y-place image) (case y-place [(top) 0] [(middle) (/ (image-bottom image) 2)] [(bottom) (image-bottom image)] - [(baseline) (image-baseline image)])) + [(baseline) (image-baseline image)] + [else (error 'find-y-spot "~s" y-place)])) ;; overlay/xy : image number number image -> image ;; places images on top of each other with their upper-left corners offset by the two numbers @@ -366,6 +376,14 @@ (if (< dx 0) 0 dx) (if (< dy 0) 0 dy))) +(define/chk (underlay/xy image dx dy image2) + (overlay/δ image2 + (if (< dx 0) 0 dx) + (if (< dy 0) 0 dy) + image + (if (< dx 0) (- dx) 0) + (if (< dy 0) (- dy) 0))) + (define (overlay/δ image1 dx1 dy1 image2 dx2 dy2) (make-image (make-overlay (make-translate dx1 dy1 (image-shape image1)) (make-translate dx2 dy2 (image-shape image2))) @@ -943,6 +961,10 @@ (provide overlay overlay/align overlay/xy + underlay + underlay/align + underlay/xy + beside beside/align above diff --git a/collects/2htdp/private/stop.ss b/collects/2htdp/private/stop.ss new file mode 100644 index 0000000000..816d57201b --- /dev/null +++ b/collects/2htdp/private/stop.ss @@ -0,0 +1,5 @@ +#lang scheme + +(provide (struct-out stop-the-world)) + +(define-struct stop-the-world (world) #:transparent) diff --git a/collects/2htdp/private/world.ss b/collects/2htdp/private/world.ss index 67f90960c9..f3e13348f5 100644 --- a/collects/2htdp/private/world.ss +++ b/collects/2htdp/private/world.ss @@ -4,6 +4,7 @@ "timer.ss" "last.ss" "checked-cell.ss" + "stop.ss" htdp/image htdp/error mzlib/runtime-path @@ -219,16 +220,26 @@ (when (package? nw) (broadcast (package-message nw)) (set! nw (package-world nw))) - (let ([changed-world? (send world set tag nw)]) - (unless changed-world? - (when draw (pdraw)) - (when (pstop) - (when last-picture - (set! draw last-picture) - (pdraw)) - (callback-stop! 'name) - (enable-images-button))) - changed-world?)))))) + (if (stop-the-world? nw) + (begin + (set! nw (stop-the-world-world nw)) + (send world set tag nw) + (when last-picture + (set! draw last-picture)) + (when draw (pdraw)) + (callback-stop! 'name) + (enable-images-button)) + (let ([changed-world? (send world set tag nw)]) + (unless changed-world? + (when draw (pdraw)) + (when (pstop) + (printf "!stop!\n") + (when last-picture + (set! draw last-picture) + (pdraw)) + (callback-stop! 'name) + (enable-images-button))) + changed-world?))))))) ;; tick, tock : deal with a tick event for this world (def/pub-cback (ptock) tick) @@ -284,7 +295,11 @@ ;; initialize the world and run (super-new) (start!) - (when (stop (send world get)) (stop! (send world get))))))) + (let ([w (send world get)]) + (cond + [(stop w) (stop! (send world get))] + [(stop-the-world? w) + (stop! (stop-the-world-world (send world get)))])))))) ;; ----------------------------------------------------------------------------- (define-runtime-path break-btn:path '(lib "icons/break.png")) diff --git a/collects/2htdp/tests/stop.ss b/collects/2htdp/tests/stop.ss new file mode 100644 index 0000000000..680fc14cd5 --- /dev/null +++ b/collects/2htdp/tests/stop.ss @@ -0,0 +1,22 @@ +;; The first three lines of this file were inserted by DrScheme. They record metadata +;; about the language level of this file in a form that our tools can easily process. +#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname test-stop) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ()))) + +(require 2htdp/universe) + +;; on RETURN stop + +(define (main debug?) + (big-bang "" + (on-key (lambda (w ke) + (cond + [(key=? ke "\r") (stop-with w)] + [(= (string-length ke) 1) + (string-append w ke)] + [else w]))) + (state debug?) + (on-draw (lambda (w) + (place-image + (text w 22 'black) + 3 3 + (empty-scene 100 100)))))) diff --git a/collects/2htdp/tests/test-image.ss b/collects/2htdp/tests/test-image.ss index abb3d83197..3554b60c5c 100644 --- a/collects/2htdp/tests/test-image.ss +++ b/collects/2htdp/tests/test-image.ss @@ -285,9 +285,9 @@ #f)) (test (overlay/align 'middle - 'middle - (ellipse 100 50 'solid 'green) - (ellipse 50 100 'solid 'red)) + 'middle + (ellipse 100 50 'solid 'green) + (ellipse 50 100 'solid 'red)) => (make-image (make-overlay @@ -297,9 +297,9 @@ #f)) (test (overlay/align 'middle - 'middle - (ellipse 50 100 'solid 'red) - (ellipse 100 50 'solid 'green)) + 'middle + (ellipse 50 100 'solid 'red) + (ellipse 100 50 'solid 'green)) => (make-image (make-overlay @@ -310,9 +310,9 @@ (test (overlay/align 'right - 'bottom - (ellipse 50 100 'solid 'red) - (ellipse 100 50 'solid 'green)) + 'bottom + (ellipse 50 100 'solid 'red) + (ellipse 100 50 'solid 'green)) => (make-image (make-overlay @@ -322,9 +322,9 @@ #f)) (test (overlay/align 'right - 'baseline - (ellipse 50 100 'solid 'red) - (ellipse 100 50 'solid 'green)) + 'baseline + (ellipse 50 100 'solid 'red) + (ellipse 100 50 'solid 'green)) => (make-image (make-overlay @@ -413,13 +413,136 @@ #f)) (test (above (ellipse 50 100 'solid 'red) - (ellipse 100 50 'solid 'blue)) + (ellipse 100 50 'solid 'blue)) => (above/align 'left (ellipse 50 100 'solid 'red) (ellipse 100 50 'solid 'blue))) + +(test (underlay (ellipse 100 100 'solid 'blue) + (ellipse 120 120 'solid 'red)) + => + (make-image + (make-overlay + (make-translate 0 0 (image-shape (ellipse 120 120 'solid 'red))) + (make-translate 0 0 (image-shape (ellipse 100 100 'solid 'blue)))) + (make-bb 120 + 120 + 120) + #f)) + +(test (underlay/xy (ellipse 100 100 'solid 'blue) + 0 0 + (ellipse 120 120 'solid 'red)) + => + (underlay (ellipse 100 100 'solid 'blue) + (ellipse 120 120 'solid 'red))) + + +(test (underlay/xy (ellipse 50 100 'solid 'red) + -25 25 + (ellipse 100 50 'solid 'green)) + => + (make-image + (make-overlay + (make-translate 0 25 (image-shape (ellipse 100 50 'solid 'green))) + (make-translate 25 0 (image-shape (ellipse 50 100 'solid 'red)))) + (make-bb 100 + 100 + 100) + #f)) + +(test (underlay/xy (ellipse 100 50 'solid 'green) + 10 10 + (ellipse 50 100 'solid 'red)) + => + (make-image + (make-overlay + (make-translate 10 10 (image-shape (ellipse 50 100 'solid 'red))) + (make-translate 0 0 (image-shape (ellipse 100 50 'solid 'green)))) + (make-bb 100 + 110 + 110) + #f)) + +(test (underlay (ellipse 100 50 'solid 'green) + (ellipse 50 100 'solid 'red)) + => + (make-image + (make-overlay + (make-translate 0 0 (image-shape (ellipse 50 100 'solid 'red))) + (make-translate 0 0 (image-shape (ellipse 100 50 'solid 'green)))) + (make-bb 100 + 100 + 100) + #f)) + +(test (underlay (ellipse 100 100 'solid 'blue) + (ellipse 120 120 'solid 'red) + (ellipse 140 140 'solid 'green)) + => + (make-image + (make-overlay + (make-translate + 0 0 + (make-overlay + (make-translate 0 0 (image-shape (ellipse 140 140 'solid 'green))) + (make-translate 0 0 (image-shape (ellipse 120 120 'solid 'red))))) + (make-translate 0 0 (image-shape (ellipse 100 100 'solid 'blue)))) + (make-bb 140 140 140) + #f)) + +(test (underlay/align 'middle + 'middle + (ellipse 100 50 'solid 'green) + (ellipse 50 100 'solid 'red)) + => + (make-image + (make-overlay + (make-translate 25 0 (image-shape (ellipse 50 100 'solid 'red))) + (make-translate 0 25 (image-shape (ellipse 100 50 'solid 'green)))) + (make-bb 100 100 100) + #f)) + +(test (underlay/align 'middle + 'middle + (ellipse 50 100 'solid 'red) + (ellipse 100 50 'solid 'green)) + => + (make-image + (make-overlay + (make-translate 0 25 (image-shape (ellipse 100 50 'solid 'green))) + (make-translate 25 0 (image-shape (ellipse 50 100 'solid 'red)))) + (make-bb 100 100 100) + #f)) + +(test (underlay/align 'right + 'bottom + (ellipse 50 100 'solid 'red) + (ellipse 100 50 'solid 'green)) + => + (make-image + (make-overlay + (make-translate 0 50 (image-shape (ellipse 100 50 'solid 'green))) + (make-translate 50 0 (image-shape (ellipse 50 100 'solid 'red)))) + (make-bb 100 100 100) + #f)) + +(test (underlay/align "right" + "baseline" + (ellipse 50 100 'solid 'red) + (ellipse 100 50 'solid 'green)) + => + (make-image + (make-overlay + (make-translate 0 50 (image-shape (ellipse 100 50 'solid 'green))) + (make-translate 50 0 (image-shape (ellipse 50 100 'solid 'red)))) + (make-bb 100 100 100) + #f)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; testing normalization @@ -831,3 +954,26 @@ 16) (check-equal? (image-height (bitmap icons/stop-16x16.png)) 16) + +(check-equal? (let () + (define bmp (make-object bitmap% 4 4)) + (define mask (make-object bitmap% 4 4)) + (define bdc (make-object bitmap-dc% bmp)) + (send bdc set-brush "black" 'solid) + (send bdc draw-rectangle 0 0 4 4) + (send bdc set-bitmap mask) + (send bdc set-brush "black" 'solid) + (send bdc clear) + (send bdc draw-rectangle 1 1 1 1) + (send bdc set-bitmap #f) + (let-values ([(bytes w h) (bitmap->bytes bmp mask)]) + bytes)) + (bytes-append #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" + #"\0\0\0\0" #"\377\0\0\0" #"\0\0\0\0" #"\0\0\0\0" + #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" + #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0")) + +;; ensure no error +(check-equal? (begin (scale 2 (make-object bitmap% 10 10)) + (void)) + (void)) diff --git a/collects/2htdp/tests/world0-stops.ss b/collects/2htdp/tests/world0-stops.ss index 60857b8753..828a602cf5 100644 --- a/collects/2htdp/tests/world0-stops.ss +++ b/collects/2htdp/tests/world0-stops.ss @@ -1,5 +1,13 @@ ;; The first three lines of this file were inserted by DrScheme. They record metadata ;; about the language level of this file in a form that our tools can easily process. -#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname world0-stops) (read-case-sensitive #t) (teachpacks ((lib "universe.ss" "teachpack" "2htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "universe.ss" "teachpack" "2htdp"))))) +#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname world0-stops) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ()))) +(require 2htdp/universe) + +"does big-bang stop when the initial world is already a final world?" (big-bang 0 (stop-when zero?) (on-tick add1)) + +"does big bang stop when the initial world is a stop world?" +(big-bang (stop-with 0) (on-tick add1)) + +(define-struct stop (x)) diff --git a/collects/2htdp/universe.ss b/collects/2htdp/universe.ss index 2c1e62050c..be9d563852 100644 --- a/collects/2htdp/universe.ss +++ b/collects/2htdp/universe.ss @@ -17,11 +17,15 @@ "private/world.ss" "private/universe.ss" "private/launch-many-worlds.ss" + "private/stop.ss" htdp/error (rename-in lang/prim (first-order->higher-order f2h))) (provide (all-from-out "private/image.ss")) +(provide + (rename-out (make-stop-the-world stop-with))) ;; World -> STOP + (provide launch-many-worlds ;; (launch-many-worlds e1 ... e2) diff --git a/collects/algol60/bd-tool.ss b/collects/algol60/bd-tool.ss index 2e95304066..5d04df0aed 100644 --- a/collects/algol60/bd-tool.ss +++ b/collects/algol60/bd-tool.ss @@ -1,35 +1,12 @@ -(module bd-tool mzscheme - (require framework/private/decode) - (decode 05c1dd6edc460c06d057f9226301b2e86c5c23690103a9835c - e53a0f50602852d2ecce8f324379adb7ef3924b6a60aeaf6fb - 48dd403909a6d24daf634c984a379d189493609a731ce33ac6 - c4a09c04d351935fc79818949360f2d6f2758c0993f6316f56 - 6c6206a92da91a7a133983683cdf40d91c440a1a36b7aa23fc - abd10d341fbd5bf5306c6e550733332856057d0369740ba555 - dfa08c7f18f40da4d12d683ca18c17666690da92aa41d21aa4 - 806255f4267206d178be814abc5b6872b3d921c94bdc2f2039 - 52d6b047df4073cbd9664fad863dfa8629e6b5e5bf9f27c624 - 7abdedebc4cc0c525b5235e4e49e2d4801c5aae84de40ca2f1 - 7c0365f33f40240554e2dd42939bcd0e495ee27e017d060dab - 0a496b9082d53c3c92fac6f8c2a0cfa0615521690d52b09a87 - cdd2ba39e30b338374069578b7d0e466b3439297b8079d2f90 - c2cca06155a13386791873cc86e7ebcb573c5f5fbe32685855 - e80cedf1112479893b24ad410a9ef1cca06155a133867990e4 - 25ee785a18529819b4f7f69ed4e0ade5ef0c525b52b570d4e4 - f0d6f277502a7beb0eed63deacd8abb796ff63907decad3bb4 - 8f79b362afde5a0ef6b1b7eee33f06a92da91af62d0efb0bef - 2d2983d496540dfb1687bde0bd256590da92aa814abc5ba8f6 - 08474d1e961e8b5d308eddfa8541738e63601cbbf50b28d5cd - 7a72ace6410ef756c31eab65068d63b71e521d1eaba7e80662 - 06a92da91ae4706f1594eaf0583d4537c8e1deea0594937bb6 - 2005b49a0739dc5b0d7bac96199463118d2039dc5b85bd3b83 - b239881454e2dd42939bcd0e4d31b7f582e967dcf7133f52f7 - 4de3f9277e3591f3d384a785994125de2d34b9d9ec2836465c - ed02496b9002655089770b4d6e363be4706ff582e967dcf713 - 3f52f74de3895f4de4fc3441413916d108121883865585626c - ed81a78519f4fb686e20695dad333368585528c6d61e787266 - 66d0f0331be8f7d1dc406ad9dc94999941c3aa8256f320877b - ab618fd53263de625d2dcc5bcadaad82722ca211941934b73a - 20877babc8cccc0c7a6c56d19bc81944e3f906d23ee6cd8abd - aee69fedc3adeaab7db8550d474d1e961e8ba1c4bb856a8f70 - d4e461e9b1d8054f0b33f3ff)) +#lang s-exp framework/private/decode +bVTbjtsgEP2VqatIdlWyadSLtFIv6lOf+wErgZkYthi8gJPN33cAO3GyfonjM2fOXDi49vgy +ao9QGy2g6j3KbQhV+Vc1E9waHkLCZ2C0Oi7fo3Om5EkfWoU9Vg3FJB60RfBOiDMTkp9/Eh8j +1LWEOmDrrAzsh+SR6rej92gjm+CmSQLcEvE7CRGF9c5GBbKBb80VJNEE7Qt/Kih0x0Rf0m+K +9/wfMieesY1Eij0fNlCLURvJBk7ideuMoaB2tgAVN50zX3c0aSXk9nnoqptKRsdocL0YTfqB +Rk2x1boPaQeUNHXbYWQnLaNq4HOzGlWoOxVTOHfQruky2W5A9JmR84kWKDe03CDstvsv+WcR +lZ6fWEmei+1gd5c+xd8fmll88O6oJUI6+l+XhbDkjIJBrfvB+QizJR4T/ERUfH2LswKGp+tu +B8UDfoKj0/IO3N+BZQ8WT7k8O3je4wbCOKDfECvbd3qlrqxCT02mjYoxxnzUFk2aOFGYtiFy +G3W25dJVmZwErvGCbdI1uBhhRdjwnkyRrJYl8BibxU1YnqLU3LhuA9UfPgxn+K19VGSnj/A3 +WetdlY4g9bTM6TEE3tHE0/HJu/jc5J3mRVIuGgS8nDwE5U65HtQvo0vbEM5L9AtzTZxYLkWI +ZzLZTJZIE6Jsmit/ZTet4rZD1iq6hPQBuLaS9kafgjDv3UxCJ0Wsm4t2MRKpP+BrpEqP5bHw +A6x6JG/zPw== diff --git a/collects/at-exp/lang/reader.ss b/collects/at-exp/lang/reader.ss index b519a3f079..5a9deb10e1 100644 --- a/collects/at-exp/lang/reader.ss +++ b/collects/at-exp/lang/reader.ss @@ -14,18 +14,19 @@ (apply p args)))) (define-values (at-read at-read-syntax at-get-info) - (make-meta-reader 'at-exp - "language path" - (lambda (str) - (let ([s (string->symbol - (string-append (bytes->string/latin-1 str) - "/lang/reader"))]) - (and (module-path? s) s))) - wrap-reader - wrap-reader - (lambda (proc) - (lambda (key defval) - (case key - [(color-lexer) - (dynamic-require 'syntax-color/scribble-lexer 'scribble-lexer)] - [else (if proc (proc key defval) defval)])))))) + (make-meta-reader + 'at-exp + "language path" + (lambda (str) + (let ([s (string->symbol + (string-append (bytes->string/latin-1 str) + "/lang/reader"))]) + (and (module-path? s) s))) + wrap-reader + wrap-reader + (lambda (proc) + (lambda (key defval) + (case key + [(color-lexer) + (dynamic-require 'syntax-color/scribble-lexer 'scribble-lexer)] + [else (if proc (proc key defval) defval)])))))) diff --git a/collects/browser/browser.scrbl b/collects/browser/browser.scrbl index 4a1032c9b2..aacb2bb56a 100644 --- a/collects/browser/browser.scrbl +++ b/collects/browser/browser.scrbl @@ -23,24 +23,24 @@ @title{@bold{Browser}: Simple HTML Rendering} -The @schememodname[browser] library provides the following -procedures and classes for parsing and viewing HTML files. The -@schememodname[browser/htmltext] library provides a simplified -interface for rendering to a subclass of the MrEd @scheme[text%] -class. The @schememodname[browser/external] library provides utilities -for launching an external browser (such as Firefox). +The @schememodname[browser] library provides the following procedures +and classes for parsing and viewing HTML files. The +@schememodname[browser/htmltext] library provides a simplified interface +for rendering to a subclass of the MrEd @scheme[text%] class. The +@schememodname[browser/external] library provides utilities for +launching an external browser (such as Firefox). @section[#:tag "browser"]{Browser} @defmodule[browser] -The browser supports basic HTML commands, plus special Scheme -hyperlinks of the form @(litchar "..."). When -the user clicks on such a link, the string @scheme[sexpr] is parsed as -a Scheme program and evaluated. Since @scheme[sexpr] is likely to -contain Scheme strings, and since escape characters are difficult for -people to read, a @litchar{|} character in @scheme[sexpr] is -converted to a @litchar{"} character before it is parsed. Thus, +The browser supports basic HTML commands, plus special Scheme hyperlinks +of the form @litchar{...}. When the user clicks +on such a link, the string @scheme[sexpr] is parsed as a Scheme program +and evaluated. Since @scheme[sexpr] is likely to contain Scheme +strings, and since escape characters are difficult for people to read, a +@litchar{|} character in @scheme[sexpr] is converted to a @litchar{"} +character before it is parsed. Thus, @verbatim[#:indent 2]{ Nowhere @@ -49,214 +49,211 @@ converted to a @litchar{"} character before it is parsed. Thus, creates a ``Nowhere'' hyperlink, which executes the Scheme program @schemeblock[ -"This goes nowhere." + "This goes nowhere." ] -The value of that program is a string. When a Scheme hyperlink returns -a string, it is parsed as a new HTML document. Thus, where the use +The value of that program is a string. When a Scheme hyperlink returns +a string, it is parsed as a new HTML document. Thus, where the use clicks on ``Nowhere,'' the result is a new page that says ``This goes nowhere.'' -The browser also treats comment forms containing @(litchar "MZSCHEME=sexpr") -specially. Whereas the @(litchar "...") form executes the -expression when the user clicks, the @(litchar "MZSCHEME") expression in a comment -is executed immediately during HTML rendering. If the result is a -string, the comment is replaced in the input HTML stream with the -content of the string. Thus, +The browser also treats comment forms containing +@litchar{MZSCHEME=sexpr} specially. Whereas the +@litchar{...} form executes the expression when +the user clicks, the @litchar{MZSCHEME} expression in a comment is +executed immediately during HTML rendering. If the result is a string, +the comment is replaced in the input HTML stream with the content of the +string. Thus, @verbatim[#:indent 2]{ } inserts the path of the current working directory into the containing -document (and ``Here'' is boldfaced). If the result is a snip instead -of a string, it replaces the comment in the document. Other types of +document (and ``Here'' is boldfaced). If the result is a snip instead +of a string, it replaces the comment in the document. Other types of return values are ignored. -If the html file is being accessed as a @(litchar "file:") url, the +If the html file is being accessed as a @litchar{file:} url, the @scheme[current-load-relative-directory] parameter is set to the directory during the evaluation of the mzscheme code (in both -examples). The Scheme code is executed through @scheme[eval]. +examples). The Scheme code is executed through @scheme[eval]. -The @(litchar "MZSCHEME") forms are disabled unless the web page is a -@(litchar "file:") url that points into the @scheme[doc] collection. +The @litchar{MZSCHEME} forms are disabled unless the web page is a +@litchar{file:} url that points into the @scheme[doc] collection. @defproc[(open-url [url (or/c url? string? input-port?)]) (is-a?/c hyper-frame%)]{ - Opens the given url - in a vanilla browser frame and returns - the frame. The frame is an instance of - @scheme[hyper-frame%]. + Opens the given url in a vanilla browser frame and returns the + frame. The frame is an instance of @scheme[hyper-frame%]. } @defboolparam[html-img-ok ok?]{ - A parameter that determines whether the browser attempts to - download and render images. + A parameter that determines whether the browser attempts to download + and render images. } @defboolparam[html-eval-ok ok?]{ - A parameter that determines whether @(litchar "MZSCHEME=") - tags are evaluated. + A parameter that determines whether @litchar{MZSCHEME=} tags are + evaluated. } @; ---------------------------------------------------------------------- @defmixin[hyper-frame-mixin (frame%) ()]{ - @defconstructor/auto-super[([url (or/c url? string? input-port?)])]{ - Shows the frame and visits @scheme[url]. - } + @defconstructor/auto-super[([url (or/c url? string? input-port?)])]{ + Shows the frame and visits @scheme[url]. + } - @defmethod[(get-hyper-panel%) (subclass?/c panel%)]{ - Returns the class that is instantiated when the frame is created. - Must be a panel with hyper-panel-mixin mixed in. Defaults to - just returning @scheme[hyper-panel%]. - } + @defmethod[(get-hyper-panel%) (subclass?/c panel%)]{ + Returns the class that is instantiated when the frame is created. + Must be a panel with hyper-panel-mixin mixed in. Defaults to just + returning @scheme[hyper-panel%]. + } - @defmethod[(get-hyper-panel) (is-a?/c panel%)]{ - Returns the hyper panel in this frame. - } + @defmethod[(get-hyper-panel) (is-a?/c panel%)]{ + Returns the hyper panel in this frame. + } } @; ---------------------------------------------------------------------- -@defclass[hyper-no-show-frame% (hyper-frame-mixin (frame:status-line-mixin frame:basic%)) ()] +@defclass[hyper-no-show-frame% + (hyper-frame-mixin (frame:status-line-mixin frame:basic%)) + ()] @; ---------------------------------------------------------------------- @defmixin[hyper-no-show-frame-mixin (frame%) ()]{ - The same as the @scheme[hyper-frame-mixin], except that it - doesn't show the frame and the initialization arguments - are unchanged. + The same as the @scheme[hyper-frame-mixin], except that it doesn't + show the frame and the initialization arguments are unchanged. } @; ---------------------------------------------------------------------- -@defclass[hyper-frame% (hyper-no-show-frame-mixin (frame:status-line-mixin frame:basic%)) ()] +@defclass[hyper-frame% + (hyper-no-show-frame-mixin (frame:status-line-mixin frame:basic%)) + ()] @; ---------------------------------------------------------------------- @defmixin[hyper-text-mixin (text%) ()]{ - An instance of a @scheme[hyper-text-mixin]-extended class - should be displayed only in an instance of a class created - with @scheme[hyper-canvas-mixin]. + An instance of a @scheme[hyper-text-mixin]-extended class should be + displayed only in an instance of a class created with + @scheme[hyper-canvas-mixin]. - @defconstructor/auto-super[([url (or/c url? string? input-port?)] - [status-frame (or/c (is-a?/c top-level-window<%>) false/c)] - [post-data (or/c false/c bytes?)])]{ - The @scheme[url] is loaded into the @scheme[text%] object - (using the @method[hyper-text-mixin reload] method), a - top-level window for status messages and dialogs, a progress - procedure used as for @scheme[get-url], and either @scheme[#f] - or a post string to be sent to a web server (technically - changing the GET to a POST). + @defconstructor/auto-super[([url (or/c url? string? input-port?)] + [status-frame + (or/c (is-a?/c top-level-window<%>) false/c)] + [post-data (or/c false/c bytes?)])]{ + The @scheme[url] is loaded into the @scheme[text%] object (using the + @method[hyper-text-mixin reload] method), a top-level window for + status messages and dialogs, a progress procedure used as for + @scheme[get-url], and either @scheme[#f] or a post string to be sent + to a web server (technically changing the GET to a POST). - Sets the autowrap-bitmap to @scheme[#f]. - } + Sets the autowrap-bitmap to @scheme[#f]. + } - @defmethod[(map-shift-style [start exact-nonnegative-integer?] - [end exact-nonnegative-integer?] - [shift-style style<%>]) - void?]{ - Maps the given style over the given range. - } + @defmethod[(map-shift-style [start exact-nonnegative-integer?] + [end exact-nonnegative-integer?] + [shift-style style<%>]) + void?]{ + Maps the given style over the given range. + } - @defmethod[(make-link-style [start exact-nonnegative-integer?] - [end exact-nonnegative-integer?]) - void?]{ - Changes the style for the given range to the link style. - } + @defmethod[(make-link-style [start exact-nonnegative-integer?] + [end exact-nonnegative-integer?]) + void?]{ + Changes the style for the given range to the link style. + } - @defmethod[(get-url) (or/c url? string? input-port? false/c)]{ - Returns the URL displayed by the editor, or @scheme[#f] if there - is none. - } + @defmethod[(get-url) (or/c url? string? input-port? false/c)]{ + Returns the URL displayed by the editor, or @scheme[#f] if there is + none. + } - @defmethod[(get-title) string?]{ - Gets the page's title. - } + @defmethod[(get-title) string?]{ + Gets the page's title. + } - @defmethod[(set-title [str string?]) void?]{ - Sets the page's title. - } + @defmethod[(set-title [str string?]) void?]{ + Sets the page's title. + } - @defmethod[(hyper-delta) style-delta%]{ - Override this method to set the link style. - } + @defmethod[(hyper-delta) style-delta%]{ + Override this method to set the link style. + } - @defmethod[(add-tag [name string?] [pos exact-nonnegative-integer?]) void?]{ - Installs a tag. - } + @defmethod[(add-tag [name string?] [pos exact-nonnegative-integer?]) void?]{ + Installs a tag. + } - @defmethod[(find-tag [name/number (or/c string? exact-nonnegative-integer?)]) - (or/c exact-nonnegative-integer? false/c)]{ - Finds the location of a tag in the buffer (where tags - are installed in HTML with @(litchar "")) and returns its position. If - @scheme[name] is a number, the number is returned - (assumed to be an offset rather than a - tag). Otherwise, if the tag is not found, @scheme[#f] - is returned. - } + @defmethod[(find-tag [name/number (or/c string? exact-nonnegative-integer?)]) + (or/c exact-nonnegative-integer? false/c)]{ + Finds the location of a tag in the buffer (where tags are installed + in HTML with @litchar{}) and returns its position. + If @scheme[name] is a number, the number is returned (assumed to be + an offset rather than a tag). Otherwise, if the tag is not found, + @scheme[#f] is returned. + } - @defmethod[(remove-tag [name string?]) void?]{ - Removes a tag. - } + @defmethod[(remove-tag [name string?]) void?]{ + Removes a tag. + } - @defmethod[(post-url [url (or/c string? url?)] - [post-data-bytes (or/c bytes? false/c) #f]) void?]{ - Follows the link, optionally with the given post data. - } + @defmethod[(post-url [url (or/c string? url?)] + [post-data-bytes (or/c bytes? false/c) #f]) void?]{ + Follows the link, optionally with the given post data. + } - @defmethod[(add-link [start exact-nonnegative-integer?] - [end exact-nonnegative-integer?] - [url (or/c url? string?)]) - void?]{ - Installs a hyperlink. - } + @defmethod[(add-link [start exact-nonnegative-integer?] + [end exact-nonnegative-integer?] + [url (or/c url? string?)]) + void?]{ + Installs a hyperlink. + } - @defmethod[(add-scheme-callback [start exact-nonnegative-integer?] - [end exact-nonnegative-integer?] - [scheme-expr string?]) - void?]{ - Installs a Scheme evaluation hyperlink. - } + @defmethod[(add-scheme-callback [start exact-nonnegative-integer?] + [end exact-nonnegative-integer?] + [scheme-expr string?]) + void?]{ + Installs a Scheme evaluation hyperlink. + } - @defmethod[(add-thunk-callback [start exact-nonnegative-integer?] - [end exact-nonnegative-integer?] - [thunk (-> any)]) - void?]{ - Installs a thunk-based hyperlink. - } + @defmethod[(add-thunk-callback [start exact-nonnegative-integer?] + [end exact-nonnegative-integer?] + [thunk (-> any)]) + void?]{ + Installs a thunk-based hyperlink. + } - @defmethod[(eval-scheme-string [str string?]) any]{ - Called to handle the @(litchar "...") - tag and @(litchar "") comments (see above). - Evaluates the string; if the result is a string, - it is opened as an HTML page. - } + @defmethod[(eval-scheme-string [str string?]) any]{ + Called to handle the @litchar{...} tag and + @litchar{} comments (see above). Evaluates the + string; if the result is a string, it is opened as an HTML page. + } - @defmethod[(reload) void?]{ - Reloads the current page. + @defmethod[(reload) void?]{ + Reloads the current page. - The text defaultly uses the basic style named - @scheme["Html Standard"] in the editor (if it exists). - } + The text defaultly uses the basic style named + @scheme["Html Standard"] in the editor (if it exists). + } - @defmethod[(remap-url [url (or/c url? string?)]) (or/c url? string?)]{ - When visiting a new page, this method is called to remap - the url. The remapped url is used in place of the - original url. If this method returns @scheme[#f], the page doesn't - go anywhere. + @defmethod[(remap-url [url (or/c url? string?)]) (or/c url? string?)]{ + When visiting a new page, this method is called to remap the url. + The remapped url is used in place of the original url. If this + method returns @scheme[#f], the page doesn't go anywhere. - This method may be killed (if the user clicks the - ``stop'' button). - } - - @defmethod[(get-hyper-keymap) (is-a?/c keymap%)]{ - Returns a keymap suitable for frame-level handling of events to - redirect page-up, @|etc| to the browser canvas. - } + This method may be killed (if the user clicks the ``stop'' button). + } + + @defmethod[(get-hyper-keymap) (is-a?/c keymap%)]{ + Returns a keymap suitable for frame-level handling of events to + redirect page-up, @|etc| to the browser canvas. + } } @@ -264,8 +261,8 @@ The @(litchar "MZSCHEME") forms are disabled unless the web page is a @defclass[hyper-text% (hyper-text-mixin text:keymap%) ()]{ - Extends the @scheme[text:keymap%] class to support standard - key bindings in the browser window. + Extends the @scheme[text:keymap%] class to support standard key + bindings in the browser window. } @@ -273,135 +270,130 @@ The @(litchar "MZSCHEME") forms are disabled unless the web page is a @defmixin[hyper-canvas-mixin (editor-canvas%) ()]{ - A @scheme[hyper-can-mixin]-extended canvas's parent should be - an instance of a class derived with - @scheme[hyper-panel-mixin]. + A @scheme[hyper-can-mixin]-extended canvas's parent should be an + instance of a class derived with @scheme[hyper-panel-mixin]. - @defconstructor/auto-super[()]{ - } + @defconstructor/auto-super[()]{ + } - @defmethod[(get-editor%) (subclass?/c text%)]{ + @defmethod[(get-editor%) (subclass?/c text%)]{ - Returns the class used to implement the editor in the browser - window. It should be derived from @scheme[hyper-text%] and - should pass on the initialization arguments to - @scheme[hyper-text%]. + Returns the class used to implement the editor in the browser + window. It should be derived from @scheme[hyper-text%] and should + pass on the initialization arguments to @scheme[hyper-text%]. - The dynamic extent of the initialization of this - editor is called on a thread that may be killed (via a - custodian shutdown). In that case, the editor in the browser's - editor-canvas may not be an instance of this class. - } + The dynamic extent of the initialization of this editor is called on + a thread that may be killed (via a custodian shutdown). In that + case, the editor in the browser's editor-canvas may not be an + instance of this class. + } - @defmethod[(current-page) any/c]{ - Returns a representation of the currently displayed page, which - includes a particular editor and a visible range within the - editor. - } + @defmethod[(current-page) any/c]{ + Returns a representation of the currently displayed page, which + includes a particular editor and a visible range within the editor. + } - @defmethod[(goto-url [url (or/c url? string?)] - [relative-to-url (or/c url? string? false/c)] - [progress-proc (boolean? . -> . any) void] - [post-data (or/c bytes? false/c) #f]) - void?]{ - Changes to the given url, loading it by calling the @scheme[make-editor] - method. If @scheme[relative-to-url] is not @scheme[#f], it must be - a URL for resolving @scheme[url] as a relative URL. - @scheme[url] may also be a port, in which case, - @scheme[relative-to-url] must be @scheme[#f]. + @defmethod[(goto-url [url (or/c url? string?)] + [relative-to-url (or/c url? string? false/c)] + [progress-proc (boolean? . -> . any) void] + [post-data (or/c bytes? false/c) #f]) + void?]{ + Changes to the given url, loading it by calling the + @scheme[make-editor] method. If @scheme[relative-to-url] is not + @scheme[#f], it must be a URL for resolving @scheme[url] as a + relative URL. @scheme[url] may also be a port, in which case, + @scheme[relative-to-url] must be @scheme[#f]. - The @scheme[progress-proc] procedure is called with a boolean at the - point where the URL has been resolved and enough progress has - been made to dismiss any message that the URL is being - resolved. The procedure is called with @scheme[#t] if the URL will be - loaded into a browser window, @scheme[#f] otherwise (e.g., the user will - save the URL content to a file). + The @scheme[progress-proc] procedure is called with a boolean at the + point where the URL has been resolved and enough progress has been + made to dismiss any message that the URL is being resolved. The + procedure is called with @scheme[#t] if the URL will be loaded into + a browser window, @scheme[#f] otherwise (e.g., the user will save + the URL content to a file). - If @scheme[post-data-bytes] is a byte string instead of false, the URL - GET is changed to a POST with the given data. - } + If @scheme[post-data-bytes] is a byte string instead of false, the + URL GET is changed to a POST with the given data. + } - @defmethod[(set-page [page any/c] [notify? any/c]) void?]{ - Changes to the given page. If @scheme[notify?] is not @scheme[#f], - the canvas's parent is notified about the change by calling its - @scheme[leaving-page] method. - } + @defmethod[(set-page [page any/c] [notify? any/c]) void?]{ + Changes to the given page. If @scheme[notify?] is not @scheme[#f], + the canvas's parent is notified about the change by calling its + @scheme[leaving-page] method. + } - @defmethod[(after-set-page) void?]{ - Called during @scheme[set-page]. Defaultly does nothing. - } + @defmethod[(after-set-page) void?]{ + Called during @scheme[set-page]. Defaultly does nothing. + } } @; ---------------------------------------------------------------------- @defmixin[hyper-panel-mixin (area-container<%>) ()]{ - @defconstructor/auto-super[([info-line? any/c])]{ - Creates controls and a hyper text canvas. The - controls permit a user to move back and forth in the hypertext - history. - - The @scheme[info-line?] argument indicates whether the browser - should contain a line to display special @(litchar "DOCNOTE") - tags in a page. Such tags are used primarily by the PLT - documentation.} - - @defmethod[(make-canvas [container (is-a?/c area-container<%>)]) void?]{ - Creates the panel's hypertext canvas, an instance of a class - derived using @scheme[hyper-canvas-mixin]. This - method is called during initialization. - } + @defconstructor/auto-super[([info-line? any/c])]{ + Creates controls and a hyper text canvas. The controls permit a + user to move back and forth in the hypertext history. - @defmethod[(get-canvas%) (subclass?/c editor-canvas%)]{ - Returns the class instantiated by make-canvas. It must be derived from - @scheme[hyper-canvas-mixin]. - } + The @scheme[info-line?] argument indicates whether the browser + should contain a line to display special @litchar{DOCNOTE} tags in a + page. Such tags are used primarily by the PLT documentation. + } - @defmethod[(make-control-bar-panel [container (is-a?/c area-container<%>)]) - any/c]{ - Creates the panel's sub-container for the control bar containing - the navigation buttons. If @scheme[#f] is returned, the panel will - have no control bar. The default method instantiates - @scheme[horizontal-panel%]. - } + @defmethod[(make-canvas [container (is-a?/c area-container<%>)]) void?]{ + Creates the panel's hypertext canvas, an instance of a class derived + using @scheme[hyper-canvas-mixin]. This method is called during + initialization. + } - @defmethod[(rewind) void?]{ - Goes back one page, if possible. - } + @defmethod[(get-canvas%) (subclass?/c editor-canvas%)]{ + Returns the class instantiated by make-canvas. It must be derived + from @scheme[hyper-canvas-mixin]. + } - @defmethod[(forward) void?]{ - Goes forward one page, if possible. - } + @defmethod[(make-control-bar-panel [container (is-a?/c area-container<%>)]) + any/c]{ + Creates the panel's sub-container for the control bar containing the + navigation buttons. If @scheme[#f] is returned, the panel will have + no control bar. The default method instantiates + @scheme[horizontal-panel%]. + } - @defmethod[(get-canvas) (is-a?/c editor-canvas%)]{ - Gets the hypertext canvas. - } + @defmethod[(rewind) void?]{ + Goes back one page, if possible. + } - @defmethod[(on-navigate) void?]{ - Callback that is invoked any time the displayed hypertext page - changes (either by clicking on a link in the canvas or by - @scheme[rewind] or @scheme[forward] calls). - } + @defmethod[(forward) void?]{ + Goes forward one page, if possible. + } - @defmethod[(leaving-page [page any/c] [new-page any/c]) - any]{ - This method is called by the hypertext canvas to notify the - panel that the hypertext page changed. The @scheme[page] is @scheme[#f] - if @scheme[new-page] is the first page for the canvas. See also - @scheme[page->editor]. - } + @defmethod[(get-canvas) (is-a?/c editor-canvas%)]{ + Gets the hypertext canvas. + } - @defmethod[(filter-notes [notes (listof string?)]) - (listof string?)]{ - Given the notes from a page as a list of strings (where - each string is a note), returns a single string to print - above the page. - } + @defmethod[(on-navigate) void?]{ + Callback that is invoked any time the displayed hypertext page + changes (either by clicking on a link in the canvas or by + @scheme[rewind] or @scheme[forward] calls). + } - @defmethod[(reload) void?]{ - Reloads the currently visible page by calling the @scheme[reload] - method of the currently displayed hyper-text. - } + @defmethod[(leaving-page [page any/c] [new-page any/c]) + any]{ + This method is called by the hypertext canvas to notify the panel + that the hypertext page changed. The @scheme[page] is @scheme[#f] + if @scheme[new-page] is the first page for the canvas. See also + @scheme[page->editor]. + } + + @defmethod[(filter-notes [notes (listof string?)]) + (listof string?)]{ + Given the notes from a page as a list of strings (where each string + is a note), returns a single string to print above the page. + } + + @defmethod[(reload) void?]{ + Reloads the currently visible page by calling the @scheme[reload] + method of the currently displayed hyper-text. + } } @; ---------------------------------------------------------------------- @@ -411,46 +403,43 @@ The @(litchar "MZSCHEME") forms are disabled unless the web page is a @; ---------------------------------------------------------------------- @defproc[(editor->page [editor (is-a?/c text%)]) any/c]{ - Creates a page record for the given editor, - suitable for use with the @scheme[set-page] method of - @scheme[hyper-canvas-mixin]. + Creates a page record for the given editor, suitable for use with the + @scheme[set-page] method of @scheme[hyper-canvas-mixin]. } @defproc[(page->editor [page any/c]) (is-a?/c text%)]{ - Extracts the editor from a page record. + Extracts the editor from a page record. } @defparam[bullet-size n exact-nonnegative-integer?]{ - Parameter controlling the point size of a - bullet. + Parameter controlling the point size of a bullet. } @defclass[image-map-snip% snip% ()]{ - Instances of this class behave like @scheme[image-snip%] objects, - except they have a @(litchar " ... ") associated with them and - when clicking on them (in the map) they will cause their - init arg text to follow the corresponding link. + Instances of this class behave like @scheme[image-snip%] objects, + except they have a @litchar{ ... } associated with them and + when clicking on them (in the map) they will cause their init arg text + to follow the corresponding link. - @defconstructor[([html-text (is-a?/c html-text<%>)])]{ - } + @defconstructor[([html-text (is-a?/c html-text<%>)])]{ + } - @defmethod[(set-key [key string?]) void?]{ - Sets the key for the image map (eg, "#key"). - } + @defmethod[(set-key [key string?]) void?]{ + Sets the key for the image map (eg, @scheme["#key"]). + } - @defmethod[(get-key) string?]{ - Returns the current key. - } + @defmethod[(get-key) string?]{ + Returns the current key. + } - @defmethod[(add-area [shape string?] - [region (listof number?)] - [href string?]) - void?]{ - Registers the shape named by @scheme[shape] whose - coordinates are specified by @scheme[region] to go to - @scheme[href] when that region of the image - is clicked on. - } + @defmethod[(add-area [shape string?] + [region (listof number?)] + [href string?]) + void?]{ + Registers the shape named by @scheme[shape] whose coordinates are + specified by @scheme[region] to go to @scheme[href] when that region + of the image is clicked on. + } } @; ---------------------------------------------------------------------- @@ -460,9 +449,9 @@ The @(litchar "MZSCHEME") forms are disabled unless the web page is a @defmodule[browser/browser-unit] @defthing[browser@ unit?]{ - -Imports @scheme[mred^], @scheme[tcp^], and @scheme[url^], and exports -@scheme[browser^].} + Imports @scheme[mred^], @scheme[tcp^], and @scheme[url^], and exports + @scheme[browser^]. +} @; ---------------------------------------------------------------------- @@ -471,9 +460,8 @@ Imports @scheme[mred^], @scheme[tcp^], and @scheme[url^], and exports @defmodule[browser/browser-sig] @defsignature[browser^ ()]{ - -Includes all of the bindings of the @schememodname[browser] -library.} + Includes all of the bindings of the @schememodname[browser] library. +} @; ---------------------------------------------------------------------- @@ -483,75 +471,73 @@ library.} @definterface[html-text<%> (text%)]{ - @defmethod[(get-url) (or/c url? string? false/c)]{ - Returns a base URL used for building - relative URLs, or @scheme[#f] if no base is available. - } + @defmethod[(get-url) (or/c url? string? false/c)]{ + Returns a base URL used for building relative URLs, or @scheme[#f] + if no base is available. + } - @defmethod[(set-title [str string?]) void?]{ - Registers the title @scheme[str] - for the rendered page. - } + @defmethod[(set-title [str string?]) void?]{ + Registers the title @scheme[str] for the rendered page. + } - @defmethod[(add-link [start exact-nonnegative-integer?] - [end exact-nonnegative-integer?] - [url (or/c url? string?)]) - void?]{ - Registers a hyperlink for the given region in rendered page. - } + @defmethod[(add-link [start exact-nonnegative-integer?] + [end exact-nonnegative-integer?] + [url (or/c url? string?)]) + void?]{ + Registers a hyperlink for the given region in rendered page. + } - @defmethod[(add-tag [name string?] [pos exact-nonnegative-integer?]) void?]{ - Installs a tag. - } + @defmethod[(add-tag [name string?] [pos exact-nonnegative-integer?]) void?]{ + Installs a tag. + } - @defmethod[(make-link-style [start exact-nonnegative-integer?] - [end exact-nonnegative-integer?]) - void?]{ - Changes the style for the given range to the link style. - } + @defmethod[(make-link-style [start exact-nonnegative-integer?] + [end exact-nonnegative-integer?]) + void?]{ + Changes the style for the given range to the link style. + } - @defmethod[(add-scheme-callback [start exact-nonnegative-integer?] - [end exact-nonnegative-integer?] - [scheme-expr string?]) - void?]{ - Installs a Scheme evaluation hyperlink. - } + @defmethod[(add-scheme-callback [start exact-nonnegative-integer?] + [end exact-nonnegative-integer?] + [scheme-expr string?]) + void?]{ + Installs a Scheme evaluation hyperlink. + } - @defmethod[(add-thunk-callback [start exact-nonnegative-integer?] - [end exact-nonnegative-integer?] - [thunk (-> any)]) - void?]{ - Installs a thunk-based hyperlink. - } + @defmethod[(add-thunk-callback [start exact-nonnegative-integer?] + [end exact-nonnegative-integer?] + [thunk (-> any)]) + void?]{ + Installs a thunk-based hyperlink. + } - @defmethod[(post-url [url (or/c string? url?)] - [post-data-bytes (or/c bytes? false/c) #f]) void?]{ - Follows the link, optionally with the given post data. - } + @defmethod[(post-url [url (or/c string? url?)] + [post-data-bytes (or/c bytes? false/c) #f]) void?]{ + Follows the link, optionally with the given post data. + } } @defmixin[html-text-mixin (text%) ()]{ - Extends the given @scheme[text%] class with implementations of the - @scheme[html-text<%>] methods. Hyperlinks are attached to clickbacks - that use @net-send-url from @schememodname[net/sendurl]. + Extends the given @scheme[text%] class with implementations of the + @scheme[html-text<%>] methods. Hyperlinks are attached to clickbacks + that use @net-send-url from @schememodname[net/sendurl]. } -@defproc[(render-html-to-text [in input-port?] +@defproc[(render-html-to-text [in input-port?] [dest (is-a? html-text<%>)] - [load-img? any/c] + [load-img? any/c] [eval-mz? any/c]) void?]{ + Reads HTML from @scheme[in] and renders it to @scheme[dest]. If + @scheme[load-img?] is @scheme[#f], then images are rendered as Xed-out + boxes. If @scheme[eval-mz?] is @scheme[#f], then @litchar{MZSCHEME} + hyperlink expressions and comments are not evaluated. - Reads HTML from @scheme[in] and renders it to @scheme[dest]. - If @scheme[load-img?] is @scheme[#f], then images are rendered - as Xed-out boxes. If @scheme[eval-mz?] is @scheme[#f], then - @litchar{MZSCHEME} hyperlink expressions and comments are not - evaluated. - - Uses the style named @scheme["Html Standard"] in the editor's - style-list (if it exists) for all of the inserted text's - default style.} + Uses the style named @scheme["Html Standard"] in the editor's + style-list (if it exists) for all of the inserted text's default + style. +} @; ---------------------------------------------------------------------- @@ -560,32 +546,33 @@ library.} @defmodule[browser/external] @defproc[(send-url [str null] [separate-window? void #t]) null]{ - Like @net-send-url from @scheme[net/sendurl] , but under Unix, - the user is prompted for a browser to use if none is recorded - in the preferences file. + Like @net-send-url from @scheme[net/sendurl], but under Unix, the user + is prompted for a browser to use if none is recorded in the + preferences file. } @defproc[(browser-preference? [v any/c]) boolean?]{ - Returns @scheme[#t] if @scheme[v] is a valid browser preference. + Returns @scheme[#t] if @scheme[v] is a valid browser preference. } @defproc[(update-browser-preference [url (or/c string? false/c)]) void?]{ - Under Unix, prompts the user for a browser preference and records - the user choice as a framework preference (even if one is already - recorded). If @scheme[url] is not @scheme[#f], it is used in the - dialog to explain which URL is to be opened; if it is @scheme[#f], - the @scheme['internal] will be one of the options for the user. + Under Unix, prompts the user for a browser preference and records the + user choice as a framework preference (even if one is already + recorded). If @scheme[url] is not @scheme[#f], it is used in the + dialog to explain which URL is to be opened; if it is @scheme[#f], the + @scheme['internal] will be one of the options for the user. } @defproc[(install-help-browser-preference-panel) void?]{ - Installs a framework preference panel for ``Browser'' options. + Installs a framework preference panel for ``Browser'' options. } -@defproc[(add-to-browser-prefs-panel [proc ((is-a?/c panel%) . -> . any)]) void?]{ - The @scheme[proc] is called when the ``Browser'' panel is constructed for - preferences. The supplied argument is the panel, so @scheme[proc] can add - additional option controls. If the panel is already created, @scheme[proc] - is called immediately. +@defproc[(add-to-browser-prefs-panel [proc ((is-a?/c panel%) . -> . any)]) + void?]{ + The @scheme[proc] is called when the ``Browser'' panel is constructed + for preferences. The supplied argument is the panel, so @scheme[proc] + can add additional option controls. If the panel is already created, + @scheme[proc] is called immediately. } @; ---------------------------------------------------------------------- @@ -595,7 +582,6 @@ library.} @defmodule[browser/tool] @defthing[tool@ unit?]{ - A unit that implements a DrScheme tool to add the ``Browser'' preference panel. } diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index 8729a983b1..0ebc8b28a6 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -321,13 +321,15 @@ list list* vector vector-immutable box))] [(3) (memq (car a) '(eq? = <= < >= > bitwise-bit-set? char=? - + - * / quotient remainder min max bitwise-and bitwise-ior + + - * / quotient remainder min max bitwise-and bitwise-ior bitwise-xor arithmetic-shift vector-ref string-ref bytes-ref set-mcar! set-mcdr! cons mcons list list* vector vector-immutable))] [(4) (memq (car a) '(vector-set! string-set! bytes-set! - list list* vector vector-immutable))] - [else (memq (car a) '(list list* vector vector-immutable))])) + list list* vector vector-immutable + + - * / min max bitwise-and bitwise-ior bitwise-xor))] + [else (memq (car a) '(list list* vector vector-immutable + + - * / min max bitwise-and bitwise-ior bitwise-xor))])) (cons '#%in a) a)) diff --git a/collects/deinprogramm/DMdA-assignments.ss b/collects/deinprogramm/DMdA-assignments.ss index 895c51d6e3..e5643dd360 100644 --- a/collects/deinprogramm/DMdA-assignments.ss +++ b/collects/deinprogramm/DMdA-assignments.ss @@ -19,5 +19,5 @@ procedures (all-from-except assignments: deinprogramm/DMdA procedures quote - symbol?)) + symbol? string->symbol symbol->string)) diff --git a/collects/deinprogramm/DMdA-beginner.ss b/collects/deinprogramm/DMdA-beginner.ss index c2d3e713fe..df0669ad0e 100644 --- a/collects/deinprogramm/DMdA-beginner.ss +++ b/collects/deinprogramm/DMdA-beginner.ss @@ -18,5 +18,5 @@ quote make-pair pair? first rest length map for-each reverse append list list-ref fold - symbol? + symbol? string->symbol symbol->string apply)) diff --git a/collects/deinprogramm/DMdA-vanilla.ss b/collects/deinprogramm/DMdA-vanilla.ss index 57e2ba777f..42eeac7356 100644 --- a/collects/deinprogramm/DMdA-vanilla.ss +++ b/collects/deinprogramm/DMdA-vanilla.ss @@ -17,5 +17,5 @@ quote eq? equal? set! define-record-procedures-2 - symbol? + symbol? string->symbol symbol->string apply)) diff --git a/collects/deinprogramm/DMdA.ss b/collects/deinprogramm/DMdA.ss index a70bddc899..de333e253e 100644 --- a/collects/deinprogramm/DMdA.ss +++ b/collects/deinprogramm/DMdA.ss @@ -316,7 +316,9 @@ (symbol? (%a -> boolean) "feststellen, ob ein Wert ein Symbol ist") (symbol->string (symbol -> string) - "Symbol in Zeichenkette umwandeln")) + "Symbol in Zeichenkette umwandeln") + (string->symbol (string -> symbol) + "Zeichenkette in Symbol umwandeln")) ("Verschiedenes" (equal? (%a %b -> boolean) diff --git a/collects/deinprogramm/scribblings/DMdA-beginner.scrbl b/collects/deinprogramm/scribblings/DMdA-beginner.scrbl index 1797640669..c3d367c184 100644 --- a/collects/deinprogramm/scribblings/DMdA-beginner.scrbl +++ b/collects/deinprogramm/scribblings/DMdA-beginner.scrbl @@ -341,7 +341,7 @@ Dieser Testfall überprüft experimentell, ob die @tech{Eigenschaft} @emph{Wichtig:} @scheme[check-property] funktioniert nur für Eigenschaften, bei denen aus den Verträgen sinnvoll Werte generiert werden können. Dies ist für die meisten eingebauten Verträge der -Fall, aber nicht für Verträge, die mit @scheme[predicate], +Fall, aber nicht für Vertragsvariablen und Verträge, die mit @scheme[predicate], @scheme[property] oder @scheme[define-record-procedures] definiert wurden. In diesen Fällen erzeugt @scheme[check-property] eine Fehlermeldung. } diff --git a/collects/deinprogramm/scribblings/image.scrbl b/collects/deinprogramm/scribblings/image.scrbl index 5c1b46baa3..73998dfe5a 100644 --- a/collects/deinprogramm/scribblings/image.scrbl +++ b/collects/deinprogramm/scribblings/image.scrbl @@ -88,20 +88,20 @@ Die folgenden Prozeduren erzeugen Bilder mit einfachen geometrischen Formen: @defthing[ellipse (natural natural mode image-color -> image)]{ Der Aufruf @scheme[(ellipse w h m c)] erzeugt eine Ellipse mit Breite @scheme[w] und Höhe @scheme[h], gefüllt mit Modus - @scheme[m] uns in Farbe @scheme[c].} + @scheme[m] und in Farbe @scheme[c].} @defthing[triangle (integer mode image-color -> image)]{ Der Aufruf @scheme[(triangle s m c)] erzeugt ein nach oben zeigendes gleichseitiges Dreieck, wobei @scheme[s] die Seitenlänge angibt, gefüllt mit Modus - @scheme[m] uns in Farbe @scheme[c].} + @scheme[m] und in Farbe @scheme[c].} @defthing[line (natural natural number number number number image-color -> image)]{ Der Aufruf @scheme[(line w h sx sy ex ey c)] erzeugt ein Bild mit einer farbigen Strecke, wobei @scheme[w] die Breite und @scheme[h] die Höhe des Bilds, sowie @scheme[sx] die X- und @scheme[sx] die Y-Koordinate des Anfangspunkts und @scheme[ex] die X- und @scheme[ey] die Y-Koordinate des Endpunkts angeben, gefüllt mit Modus - @scheme[m] uns in Farbe @scheme[c].} + @scheme[m] und in Farbe @scheme[c].} @defthing[text (string natural image-color -> image)]{ Der Aufruf @scheme[(text s f c)] diff --git a/collects/drscheme/private/frame.ss b/collects/drscheme/private/frame.ss index c1569033b5..ff8c7ca4b0 100644 --- a/collects/drscheme/private/frame.ss +++ b/collects/drscheme/private/frame.ss @@ -27,6 +27,18 @@ (define basics-mixin (mixin (frame:standard-menus<%>) (basics<%>) + + (define/override (on-subwindow-char receiver event) + (let ([user-key? (send (keymap:get-user) + handle-key-event + (if (is-a? receiver editor-canvas%) + (send receiver get-editor) + receiver) + event)]) + ;; (printf "user-key? ~s\n" user-key?) returns #t for key release events -- is this a problem? (we'll find out!) + (or user-key? + (super on-subwindow-char receiver event)))) + (inherit get-edit-target-window get-edit-target-object get-menu-bar) (define/private (get-menu-bindings) (let ([name-ht (make-hasheq)]) diff --git a/collects/drscheme/private/tools.ss b/collects/drscheme/private/tools.ss index 3e16767fcc..e446f0b925 100644 --- a/collects/drscheme/private/tools.ss +++ b/collects/drscheme/private/tools.ss @@ -316,6 +316,8 @@ (let loop ([sexp full-sexp]) (match sexp + [`((#%module-begin ,body ...)) + (loop body)] [`((provide/doc (,x ,name ,ctc ,other ...) ...) ,rest ...) #`(let #,(map (λ (name ctc) (with-syntax ([name (datum->syntax #'tool-name name)] @@ -331,7 +333,7 @@ [`(,a . ,b) (loop b)] [`() - (error 'tcl.ss "did not find provide/doc" full-sexp)])))])) + (error 'tcl.ss "did not find provide/doc: ~a" full-sexp)])))])) ;; invoke-tool : unit/sig string -> (values (-> void) (-> void)) ;; invokes the tools and returns the two phase thunks. diff --git a/collects/eopl/eopl.scrbl b/collects/eopl/eopl.scrbl index 1296467202..4dc194df97 100644 --- a/collects/eopl/eopl.scrbl +++ b/collects/eopl/eopl.scrbl @@ -4,7 +4,7 @@ scheme/list (for-label eopl/eopl scheme/contract - (only-in scheme printf pretty-print))) + (only-in scheme printf pretty-print delay force))) @(define-syntax-rule (def-mz id) (begin diff --git a/collects/framework/gui-utils.ss b/collects/framework/gui-utils.ss index 81d883acf1..c50be8fb68 100644 --- a/collects/framework/gui-utils.ss +++ b/collects/framework/gui-utils.ss @@ -1,5 +1,4 @@ -#reader scribble/reader -#lang scheme/base +#lang at-exp scheme/base (require string-constants scheme/gui/base scheme/contract scheme/class) diff --git a/collects/framework/private/bday.ss b/collects/framework/private/bday.ss index 72b3d33c00..42dabb813e 100644 --- a/collects/framework/private/bday.ss +++ b/collects/framework/private/bday.ss @@ -1,40 +1,32 @@ -#lang scheme/base -(require "decode.ss") -(decode - \5d8f4 - \10ec22010 - \45aff297b02 - \0 \69d544 - \5da867 - \299da9 - \360a3 - \5404db - \cbde0b - \4b571f - \7798f6 - \13ecaf - \2b5f75 - \0cf30bc - \7a62b8d0 - \194bcdfb - \023787789 - \f02\5b091a - \8ab \8eb3d4 - \3a9 \02e040 - \3ac \307a74 - \ca8 \495944 - \6e0 \74fd1 - \9ce5 \d88e21 - \b04 \f66c25 - \a97f \b8d27a - \813 \be13c6 - \0d3e \dd50a2 - \86d3 \3f5ede - \174a \3235ad9 - \ecb40 \2aecb1 - \ad56 \76292fb - \6aeb0 \39ae75f - \8f335 \ea955 - \e7e \2c7 +#lang s-exp framework/private/decode - ||\6||\8||\7||\4||\3||\d||\e||\f||\c||\0||\1) + XY9BD + sIgEEWv + 8pfMgqRV + E3Whn + qXtT + GOjg + AE08 + fYWp + 62Nu + 897D + PMxjx + heAwtc + 7G3Lzfs + CN4 d0m + 4K0G giGp + R+8w JgC4 + MA0w rvkk + XCTR 5GkC + 56T Peux + e8Yo PtsJ + E5X7 jWeY + E74T 1gWf + ryiR 4OjH + y/tK Waem + 1XMZ aIU9 + ttXK LuXV + 1hU2 x7WO + f75G vdLLj + 9Xuc CD6A + \\\\ A== diff --git a/collects/framework/private/decode.ss b/collects/framework/private/decode.ss index da5f086199..47fdae061a 100644 --- a/collects/framework/private/decode.ss +++ b/collects/framework/private/decode.ss @@ -1,43 +1,19 @@ #lang scheme/base -(require (for-syntax mzlib/inflate - scheme/base)) +(require (for-syntax scheme/base file/gunzip net/base64)) +(provide (except-out (all-from-out scheme/base) #%module-begin) + (rename-out [module-begin #%module-begin])) -(provide decode) - -(define-syntax (decode stx) +(define-syntax (module-begin stx) (syntax-case stx () - [(_ arg ...) - (andmap identifier? (syntax->list (syntax (arg ...)))) - (let () - (define (decode-sexp str) - (let* ([loc - (let loop ([chars (string->list str)]) - (cond - [(null? chars) '()] - [(null? (cdr chars)) (error 'to-sexp "missing digit somewhere")] - [else (let ([fst (to-digit (car chars))] - [snd (to-digit (cadr chars))]) - (cons - (+ (* fst 16) snd) - (loop (cddr chars))))]))]) - (let-values ([(p-in p-out) (make-pipe)]) - (inflate (open-input-bytes (apply bytes loc)) p-out) - (read p-in)))) - - (define (to-digit char) - (cond - [(char<=? #\0 char #\9) - (- (char->integer char) - (char->integer #\0))] - [(char<=? #\a char #\f) - (+ 10 (- (char->integer char) - (char->integer #\a)))])) - - (define decoded - (decode-sexp - (apply - string-append - (map (λ (x) (symbol->string (syntax-e x))) - (syntax->list (syntax (arg ...))))))) - - (datum->syntax stx decoded stx))])) + [(_ x ...) + (andmap (lambda (x) (or identifier? (integer? (syntax-e x)))) + (syntax->list #'(x ...))) + (let* ([data (format "~a" (syntax->datum #'(x ...)))] + [data (substring data 1 (sub1 (string-length data)))] + [data (string->bytes/utf-8 data)] + [in (open-input-bytes (base64-decode data))] + [out (open-output-string)] + [out (begin (inflate in out) (get-output-string out))] + [exprs (read (open-input-string (string-append "(" out ")")))] + [exprs (datum->syntax stx exprs stx)]) + #`(#%module-begin #,@exprs))])) diff --git a/collects/framework/private/encode.ss b/collects/framework/private/encode.ss index 45084ac28c..4e3c455c02 100644 --- a/collects/framework/private/encode.ss +++ b/collects/framework/private/encode.ss @@ -1,67 +1,43 @@ #lang scheme/base -(require mzlib/deflate - mzlib/match - mzlib/pretty) -(require (for-syntax mzlib/inflate - mzlib/string)) +(require scheme/cmdline scheme/string scheme/match scheme/pretty + file/gzip file/gunzip net/base64) -(provide encode-sexp - encode-module) +(define (encode-exprs exprs) + (define in + (open-input-string + (string-join (map (lambda (x) (format "~s" x)) exprs) " "))) + (define out (open-output-bytes)) + (deflate in out) + (base64-encode (get-output-bytes out))) -(define (encode-module in-filename out-filename) - (call-with-input-file in-filename - (λ (port) - (let ([mod (read port)]) - (unless (eof-object? (read port)) - (error 'encode-module "found an extra expression")) - (match mod - [`(module ,m mzscheme ,@(bodies ...)) - (call-with-output-file out-filename - (λ (oport) - (let ([chopped (chop-up (encode-sexp `(begin ,@bodies)))]) - (fprintf oport "(module ~a mzscheme\n" m) - (fprintf oport " (require framework/private/decode)\n") - (fprintf oport " (decode ~a" (car chopped)) - (for-each (lambda (chopped) - (fprintf oport "\n ~a" chopped)) - (cdr chopped)) - (fprintf oport "))\n"))) - 'truncate 'text)] - [else (error 'encode-module "cannot parse module")]))))) +(define (encode-module) + (define mod (parameterize ([read-accept-reader #t]) (read))) + (when (eof-object? mod) (error 'encode-module "missing module")) + (match mod + [(list 'module m 'scheme/base (list '#%module-begin exprs ...)) + (write-bytes #"#lang s-exp framework/private/decode\n") + (write-bytes (regexp-replace* #rx"\r\n" (encode-exprs exprs) #"\n"))] + [else (error 'encode-module "cannot parse module, must use scheme/base")])) -(define (chop-up sym) - (let ([chopping-point 50]) - (let loop ([str (symbol->string sym)]) - (cond - [(<= (string-length str) chopping-point) - (list (string->symbol str))] - [else - (cons (string->symbol (substring str 0 chopping-point)) - (loop (substring str chopping-point (string-length str))))])))) +(define (decode-module) + (define mod (parameterize ([read-accept-reader #t]) (read))) + (when (eof-object? mod) (error 'encode-module "missing module")) + (match mod + [(list 'module m 'framework/private/decode + (list '#%module-begin exprs ...)) + (write-bytes #"#lang scheme/base\n") + (let* ([data (format "~a" exprs)] + [data (substring data 1 (sub1 (string-length data)))] + [data (string->bytes/utf-8 data)] + [in (open-input-bytes (base64-decode data))] + [out (open-output-string)] + [out (begin (inflate in out) (get-output-string out))] + [exprs (read (open-input-string (string-append "(" out ")")))]) + (for ([expr (in-list exprs)]) + (pretty-print expr)))] + [else (error 'decode-module "cannot parse module, must use scheme/base")])) -(define (encode-sexp sexp) - (define (str->sym string) - (string->symbol - (apply - string-append - (map - (λ (x) - (to-hex x)) - (bytes->list string))))) - - (define (to-hex n) - (let ([digit->hex - (λ (d) - (cond - [(<= d 9) d] - [else (integer->char (+ d -10 (char->integer #\a)))]))]) - (cond - [(< n 16) (format "0~a" (digit->hex n))] - [else (format "~a~a" - (digit->hex (quotient n 16)) - (digit->hex (modulo n 16)))]))) - - (let ([in (open-input-string (format "~s" sexp))] - [out (open-output-bytes)]) - (deflate in out) - (str->sym (get-output-bytes out)))) +(command-line #:once-any + ["-e" "encode" (encode-module) (exit)] + ["-d" "decode" (decode-module) (exit)]) +(printf "Use `-h' for help\n") diff --git a/collects/honu/private/debug.ss b/collects/honu/private/debug.ss index 49f1314323..40baf40a26 100644 --- a/collects/honu/private/debug.ss +++ b/collects/honu/private/debug.ss @@ -4,7 +4,7 @@ (provide debug) -(define-for-syntax verbose? #f) +(define-for-syntax verbose? #t) (define-syntax (debug stx) (if verbose? (syntax-case stx () diff --git a/collects/honu/private/honu.ss b/collects/honu/private/honu.ss index dd8a1ea7a4..1c1396b0fb 100644 --- a/collects/honu/private/honu.ss +++ b/collects/honu/private/honu.ss @@ -126,6 +126,7 @@ (let ([v (syntax-local-value (stx-car first) (lambda () #f))]) (and (honu-transformer? v) v))] [else #f])))) + ;; (printf "~a bound transformer? ~a\n" stx (bound-transformer stx)) (or (bound-transformer stx) (special-transformer stx))) diff --git a/collects/honu/private/macro.ss b/collects/honu/private/macro.ss index 1dd5b15182..9003b17776 100644 --- a/collects/honu/private/macro.ss +++ b/collects/honu/private/macro.ss @@ -1,8 +1,13 @@ #lang scheme/base (require "honu.ss" - (for-syntax "debug.ss") - (for-syntax scheme/base)) + (for-syntax "debug.ss" + "contexts.ss" + scheme/base + syntax/parse + syntax/stx + scheme/pretty + scheme/trace)) (provide honu-macro) @@ -21,6 +26,9 @@ (loop out #'(rest1 rest ...))] [(foo) out]))) +(define-syntax (semicolon stx) + stx) + (define-for-syntax (extract-patterns pattern) (let loop ([out '()] [in pattern]) @@ -36,6 +44,29 @@ #'(rest1 rest ...)))] [(foo) (reverse (cons #'foo out))]))) +#| +(define-for-syntax (convert stx) + (syntax-case stx (...) + [(_ x ...) + |# + +(define-for-syntax (fix-template stx) stx) + +#| +(define-for-syntax (fix-template stx) + [(any \; + (... ...) rest1 rest ...) + (loop (cons #'(semicolon any (... ..))) + #'(rest1 rest ...))] + [((any1 any ...) rest1 rest ...) + (loop (loop out #'(any1 any ...)) + #'(rest1 rest ...))] + |# + + +;; x = 1 + y; ... + +#; (define-honu-syntax honu-macro (lambda (stx ctx) (debug "Original macro: ~a\n" (syntax->datum stx)) @@ -47,7 +78,10 @@ (with-syntax ([(conventions ...) (extract-conventions #'(pattern ...))] [(raw-patterns ...) - (extract-patterns #'(pattern ...))]) + (extract-patterns #'(pattern ...))] + [(fixed-template ...) + (fix-template #'(template ...))]) + (debug "new template ~a\n" (syntax->datum #'(fixed-template ...))) (values (syntax/loc stx @@ -80,7 +114,7 @@ [(name pattern ...) #'(honu-unparsed-block #f obj 'obj #f ctx - template ...)])) + fixed-template ...)])) (let ([result (syntax-case stx #; @@ -92,7 +126,7 @@ [(name raw-patterns ...) #'(honu-unparsed-block #f obj 'obj #f ctx - template ...)] + fixed-template ...)] [else 'fail-boat])]) (debug "result was ~a\n" result)) (syntax-case stx (honu-literal ...) @@ -100,7 +134,7 @@ (values #'(honu-unparsed-block #f obj 'obj #f ctx - template ...) + fixed-template ...) #'rrest)]))) #; (define-honu-syntax name @@ -115,7 +149,289 @@ (values #'(honu-unparsed-block #f obj 'obj #f ctx - template ...) + fixed-template ...) #'rrest)]))))) #'rest))]) )) + +(define-for-syntax (delimiter? x) + (or (free-identifier=? x #'\;))) + +(define-syntax (my-ellipses stx) (raise-syntax-error 'my-ellipses "dont use this")) +;; (define-syntax (wrapped stx) (raise-syntax-error 'wrapped "dont use wrap")) +;; just a phase 0 identifier +(define wrapped #f) +(define unwrap #f) + +(define-for-syntax (pull stx) + (define (reverse-syntax stx) + (with-syntax ([(x ...) (reverse (syntax->list stx))]) + #'(x ...))) + (define-syntax-class stop-class + (pattern x:id #:when (or (free-identifier=? #'x #'(... ...)) + (free-identifier=? #'x #'\;)))) + (define (do-ellipses stx) + (let loop ([ellipses '()] + [body '()] + [stx stx]) + (cond + [(null? stx) (values (with-syntax ([(ellipses ...) ellipses] + [(body ...) body]) + #'(ellipses ... body ...)) + stx)] + [(and (identifier? (car stx)) + (free-identifier=? (car stx) #'(... ...))) + (loop (cons #'(... ...) ellipses) body (cdr stx))] + [(and (identifier? (car stx)) + (free-identifier=? (car stx) #'\;)) + ;; (printf "Found a ; in ~a\n" (syntax->datum stx)) + (with-syntax ([all (cdr stx)]) + ;; (printf "Found a ; -- ~a\n" (syntax->datum #'all)) + (syntax-parse #'all + [((~and x (~not _:stop-class)) ... stop:stop-class y ...) + (with-syntax ([(ellipses ...) ellipses] + [(x* ...) (reverse-syntax #'(x ...))]) + (values #'(ellipses ... (wrapped x* ... \;) unwrap) + #'(stop y ...)))] + [else (with-syntax ([(f ...) (reverse-syntax #'all)] + [(ellipses ...) ellipses]) + (values #'(ellipses ... (wrapped f ... \;) unwrap) + #'()))]))]))) + (let loop ([all '()] + [stx (reverse (syntax->list stx))]) + (if (null? stx) + (with-syntax ([x all]) + #'x) + (let ([head (car stx)] + [tail (cdr stx)]) + (cond + [(and (identifier? head) + (free-identifier=? head #'(... ...))) + (let-values ([(wrapped rest) (do-ellipses (cons head tail))]) + (loop (cons (reverse-syntax wrapped) all) (syntax->list rest)))] + [else (loop (cons head all) tail)]))))) + +;; rename this to wrap +#; +(define-for-syntax (pull stx) + (define (reverse-syntax stx) + (with-syntax ([(x ...) (reverse (syntax->list stx))]) + #'(x ...))) + (define-syntax-class delimiter-class + (pattern x:id #:when (delimiter? #'x))) + (define-syntax-class ellipses-class + (pattern x:id #:when (free-identifier=? #'x #'(... ...)))) + (define-syntax-class not-ellipses-class + (pattern x:id #:when (not (free-identifier=? #'x #'(... ...))))) + ;; use this if you are defining your own ellipses identifier + #; + (define-syntax-class ellipses-class + #:literals (...) + (pattern my-ellipses)) + (if (not (stx-pair? stx)) + stx + (let ([stx (reverse (syntax->list stx))]) + ;; (debug-parse stx (ellipses1:ellipses-class ellipses:ellipses-class ... x ...)) + ;; (printf "stx is ~a\n" stx) + ;; (printf "... = ~a\n" (free-identifier=? #'(... ...) (stx-car stx))) + (syntax-parse stx + [(before:not-ellipses-class ... ellipses1:ellipses-class ellipses:ellipses-class ... delimiter:delimiter-class x ...) + (with-syntax ([(x* ...) (reverse-syntax (pull #'(delimiter x ...)))]) + (reverse-syntax + (with-syntax ([wrapped #'wrapped] + [original + (with-syntax ([(ellipses* ...) (map (lambda (_) + #'((... ...) (... ...))) + (syntax->list #'(ellipses1 ellipses ...)))] + [(x-new ...) (generate-temporaries #'(delimiter x ...))]) + (reverse-syntax #'(before ... ellipses* ... x-new ...)))] + #; + [original (syntax->datum (reverse-syntax #'(ellipses1 ellipses ... x ...)))]) + #'(ellipses1 ellipses ... (wrapped x* ...) unwrap))))] + [(ellipses1:ellipses-class ellipses:ellipses-class ... x ...) + (with-syntax ([(x* ...) (reverse-syntax (pull #'(x ...)))]) + (reverse-syntax + (with-syntax ([wrapped #'wrapped] + [original + (with-syntax ([(ellipses* ...) (map (lambda (_) + #'((... ...) (... ...))) + (syntax->list #'(ellipses1 ellipses ...)))] + [(x-new ...) (generate-temporaries #'(x ...))]) + (reverse-syntax #'(ellipses* ... x-new ...)))] + #; + [original (syntax->datum (reverse-syntax #'(ellipses1 ellipses ... x ...)))]) + #'(ellipses1 ellipses ... (wrapped x* ...) unwrap))))] + [(x ...) (with-syntax ([(x* ...) (map pull (syntax->list #'(x ...)))]) + (reverse-syntax #'(x* ...)))])))) + +;; (begin-for-syntax (trace pull)) + +(define-for-syntax (unpull stx) + (define-syntax-class ellipses-class + (pattern x:id #:when (free-identifier=? #'x #'(... ...)))) + (define-syntax-class delimiter-class + (pattern x:id #:when (delimiter? #'x))) + ;; (printf "unpull ~a\n" (syntax->datum stx)) + (syntax-parse stx + #:literals (wrapped unwrap) + [((~and z (~not (unwrap _ ...))) ... (unwrap (wrapped x ... delimiter:delimiter-class) ...) rest ...) + (with-syntax ([(x1 ...) (apply append (map syntax->list (syntax->list #'((x ... delimiter) ...))))] + [(rest* ...) (unpull #'(rest ...))]) + #'(z ... x1 ... rest* ...))] + [(unwrap (wrapped x ... delimiter:delimiter-class) ...) + (with-syntax ([(x1 ...) (apply append (map syntax->list (syntax->list #'((x ... delimiter) ...))))]) + #'(x1 ...))] + [(unwrap (wrapped x ... y) ...) + (with-syntax ([(x1 ...) (car (syntax->list #'((x ...) ...)))]) + (with-syntax ([(x1* ...) (map unpull (syntax->list #'(x1 ...)))] + [(y* ...) (map unpull (syntax->list #'(y ...)))]) + #'(x1* ... y* ...)))] + [(unwrap . x) (raise-syntax-error 'unpull "unhandled unwrap ~a" stx)] + [(x ...) (with-syntax ([(x* ...) (map unpull (syntax->list #'(x ...)))]) + #'(x* ...))] + [else stx])) + +;; rename this to unwrap +#; +(define-syntax (unpull stx) + (define-syntax-class ellipses-class + (pattern x:id #:when (free-identifier=? #'x #'(... ...)))) + (define (do-it stx) + (syntax-parse stx + #:literals (wrapped) + [((wrapped x ... y) ...) + (with-syntax ([(x1 ...) (car (syntax->list #'((x ...) ...)))]) + #'(x1 ... y ...))] + [((wrapped x ...) ellipses1:ellipses-class ellipses:ellipses-class ...) + (with-syntax ([(x* ...) (map do-it (syntax->list #'(x ...)))]) + #'(x* ... ellipses1 ellipses ...))] + [(x ...) (with-syntax ([(x* ...) (map do-it (syntax->list #'(x ...)))]) + #'(x* ...))] + [else stx])) + (syntax-case stx () + [(_ x ...) (do-it #'(x ...))])) + +;; (provide unpull) +#; +(define-honu-syntax unpull + (lambda (stx ctx) + (define-syntax-class ellipses-class + (pattern x:id #:when (free-identifier=? #'x #'(... ...)))) + (define (do-it stx) + (syntax-parse stx + #:literals (wrapped) + [((wrapped x ... y) ...) + (with-syntax ([(x1 ...) (car (syntax->list #'((x ...) ...)))]) + #'(x1 ... y ...))] + [((wrapped x ...) ellipses1:ellipses-class ellipses:ellipses-class ...) + (with-syntax ([(x* ...) (map do-it (syntax->list #'(x ...)))]) + #'(x* ... ellipses1 ellipses ...))] + [(x ...) (with-syntax ([(x* ...) (map do-it (syntax->list #'(x ...)))]) + (printf "x* is ~a\n" #'(x* ...)) + #'(x* ...))] + [else stx])) + (syntax-case stx () + [(_ x ...) (values (do-it #'(x ...)) + #'())]))) + +#; +(define-syntax (test stx) + (syntax-case stx () + [(_ x ...) + (begin + (pretty-print (syntax->datum (pull #'(x ...)))) + (pretty-print (syntax->datum (unpull (pull #'(x ...))))) + #'1)])) + +(define-syntax (my-syntax stx) + (syntax-case stx () + [(_ name pattern template) + (with-syntax ([wrap-it (pull #'template)]) + #'(define-syntax (name stx) + (syntax-case stx () + [pattern #'wrap-it] + [else (raise-syntax-error 'name (format "~a does not match pattern ~a" + (syntax->datum stx) + 'pattern))] + )))])) + +(define-syntax (test2 stx) + (syntax-case stx () + [(_ x ...) + (begin + (with-syntax ([pulled (pull #'(x ...))]) + #'(unpull pulled)))])) + +(define-honu-syntax honu-macro + (lambda (stx ctx) + (syntax-case stx (#%parens #%braces) + [(_ (#%parens honu-literal ...) + (#%braces (#%braces name pattern ...)) + (#%braces (#%braces template ...)) + . rest) + (with-syntax ([pulled (pull #'(template ...))] + [(pattern* ...) (map (lambda (stx) + (if (and (identifier? stx) + (not (ormap (lambda (f) + (free-identifier=? stx f)) + (syntax->list #'(honu-literal ...)))) + (not (free-identifier=? stx #'(... ...)))) + (with-syntax ([x stx]) + #'(~and x (~not (~or honu-literal ...)))) + stx)) + (syntax->list #'(pattern ...)))] + ) + (values + #'(define-honu-syntax name + (lambda (stx ctx) + ;; (define-literal-set literals (honu-literal ...)) + (syntax-parse stx + ;; #:literal-sets (literals) + #:literals (honu-literal ...) + [(name pattern* ... . rrest) + (with-syntax ([(out (... ...)) (unpull #'pulled)]) + (define (X) (raise-syntax-error (syntax->datum #'name) "implement for this context")) + (values + ;; this is sort of ugly, is there a better way? + (cond + [(type-context? ctx) (X)] + [(type-or-expression-context? ctx) (X)] + [(expression-context? ctx) #'(honu-unparsed-expr out (... ...))] + [(expression-block-context? ctx) + #'(honu-unparsed-begin out (... ...))] + [(block-context? ctx) + #'(honu-unparsed-begin out (... ...))] + [(variable-definition-context? ctx) (X)] + [(constant-definition-context? ctx) (X)] + [(function-definition-context? ctx) (X)] + [(prototype-context? ctx) (X)] + [else #'(honu-unparsed-expr out (... ...))]) + #; + #'(honu-unparsed-begin out (... ...)) + #'rrest) + #; + #'(honu-unparsed-block + #f obj 'obj #f ctx + out (... ...)) + #; + (values + #; + #'(honu-unparsed-expr out (... ...)) + #'(honu-unparsed-block + #f obj 'obj #f ctx + out (... ...) rrest) + #; + #'rrest))]))) + #'rest))]))) + +;; (my-syntax guz (_ display (#%parens x ...)) (+ x ...)) +;; (guz display (#%parens 1 2 3 4)) + +;; (local-expand stx 'expression (list #'wrapped)) + +#| +(begin-for-syntax + (trace pull)) +(test display (#%parens x)) +(test display (#%parens x ... ...) ...) +|# diff --git a/collects/htdp/image.ss b/collects/htdp/image.ss index 2f5b66c5e8..182c2a099d 100644 --- a/collects/htdp/image.ss +++ b/collects/htdp/image.ss @@ -407,7 +407,7 @@ plt/collects/tests/mzscheme/htdp-image.ss (cond [(string=? str "") (let-values ([(tw th) (get-text-size size "dummyX")]) - (rectangle 0 th 'solid 'black))] + (put-pinhole (rectangle 0 th 'solid 'black) 0 0))] [else (let ([color (make-color% color-in)]) (let-values ([(tw th) (get-text-size size str)]) diff --git a/collects/htdp/show-queen.ss b/collects/htdp/show-queen.ss index c1df747447..bde960a47f 100644 --- a/collects/htdp/show-queen.ss +++ b/collects/htdp/show-queen.ss @@ -1 +1,22 @@ -(module show-queen mzscheme (require framework/private/decode) (decode ad56db8ee3360cfd15368b05eca6eecc60fbb05834cd1f14e81714b2cd444a65c923cbb9ec43bfbda464d97226b3e8167db2c5cb21451d512c6a3c2a0385c3d751398442ab1a369dc3f6e761d8c4bf4d39891b2d8681e525497a67cfaa4518a4bd54af23a221618b0765107a876765c7a13a38d1217c382caae6231401071a61ce62a0e541a16ea13857b515ae850fcf05e30fea2bc273397b3ef563ad55038532ca4330652bf43f40f2a42c075ffd76c6c65b0745277a5849a25399dc428422ea2a8de6e86582621b6baa5e28e3f3149c3a0b4f4e47f4a0e054ceee0e0fabff94922ac9aae4a4253aca9b1cab462b34be0ae179dd36e55c844ec56a7527fe2e91ed199de372735a78267fc0b3277d630db915bcdf01e997a4d0d1c998e3becc44e440f159c88749d9170589af99056772652d2d6e77f21bcb0f76346d650deea7d40eb457148dac06dab7b2c4222dbaba15b45b38c1156ee0a51aaa4bfc48f2b848242bc119ffba238b98c296fea225a392e20631876d8290cba1e559f0fe47a391c8144189c442efe9643a55ceab1374a7d99deaabe6ff5338c1e59c439409308bb38e61ac8ff0e167851c4e2e4187c51df652558d229d512c0a1d202174a7ef817bc48da84f67dc3681ab4cb1ff766203f3d56aeb0620ac4dad45f317b505ad8ed21f9db86d12c948db3a7121f2375e98a3c66f1060b93d8a6e8d970ee952196cabfab68f5598d4ef449f7ad23b5aeb283e6ecafbcc506bd50f18f9563ca5dc3eb321332d896414fd980c3e3dfdb22c6558962b2ec78c8b5de2dd2ea7dca30c8f8ebae59bcafdaff9ad0832b7ad37e77f884ca9ce428f480c2f8a0bf039ddb5a972e91a976af0d843f13a5acf7ab840b48042deab24ac9cb5b5a425aa3d93e04a1df740809d6d476d33946b6cfae9ce7155832a2530ed3a50e72b3abb870855424a6d9bfe5ecafbd8a710fbb68e2de7d8b7fbd8a707b1651efb36c596736cb98a7d80f76e56cc684bda97f211e23314d5b460b0bb6e586608ea0ee19a235c57084ba34d1419c61e5d65f09211e69eb87df8853a7c32dab255cfb72008bc445e55fce402c150f7745513ee76b09a505e22416870b05aa5d778c1abdd38c80c31ac1f6246cb98d43d66b6956fb497ecf232c42ebd0ebbf434ecb882d1b69ada73946e27e93649f3900f869e30eaac44c53237cdc3cca4fa934a348d65ab97878bb09f8d49c403cedcc1afe5caecba98d4d6d27363584659cef30d3d1a59e1b2296e83d79efa03b620c2fc04f6307f27ac01683bcaf4a3ff098ed67f81bf71b320c7d66846ad9774df8f46a71ca1a01b29488d14360e4f17451399088f2547e7425293dc64cd48f17ee3e4b60c7759d1de546807b94f56907f550f4e7572a55af0ca8e3457c5ea780b9df08d04eeb049cfd6d20f69a98c99cc87b785cbbaac41a26b1874c3981118b5bc3a9936ce448170e47489bf1f79cf356ad8fc0e7ff01e067e6c68e394f7a767ee8012f9010f8b798099481a60784aef85e3269e62a77b3a99ada6f0b7599161cc8a0bc9931afb9f6db89cff00)) +#lang s-exp framework/private/decode +rVbbjqQ2EP2VSq9WgnTIzGjzsFql038QKV8QGSja7oDNGNOXfci3p8rGYJieVTbKE7gup8rl +43JlFl9HZRGyVpWw6yzWPw/DLvzt8klctWIYWJ6TpLfmomqEQZpr8ToiahLW2CiN0Fu8KDMO +RWNFh/ChWVTVR8g8DlRCX8RAy0ZhW0N2KUojbA0fMoYf1FeE53x2fOrHslUVZEorB96SrdD9 +ANGRkhxc8dsFK2csZJ3oYSUJTnl08xGyoCta1CcnIxTbGF30QmmXpmDVRThyOqEDBed8drfY +rP5jSionq5yTlmgpb3IsqlahdoUPz+u6yucadCoUqzvzd4lsLmgtV5vTwgv5A14c6SujyS3j +/Q5IvySFjg5Gn455IiIHis9CPkvKPstIfEssOJMba2lx38jvLG/MqOvCaDxOqTW0VxSVLAba +tzKagEVX1oJ2C2e4wR2cVENxDR9JHleJZCU4418PZBFS2NNfsGRUUtwh5LCPEHI5tDQL3v+o +WyQuBVDisGiPdDKdyufVGbrz7E71VfP/2Z/gcs4+ygSYxFnH0MYFeP+zQvYnF6H9YoO9VLVF +Ec8oFIUOkBC68/fAPeJG0MczrivPVabYfzuxgflqWmMHIKxd2YrqL+oKrTpJd7LivoskI21t +xZXIXzmhTy1+gwDL7VF0a5y0SJdKY12U92OowqR+J/rUkt7RGkvxcZdvM8O2Vf2AgW/ZU8zt +Mxsy06JIBtGP0eDT0y/LUvplvuJyyDg7RN4dUso9yvBkqVm+qdz/mt+KIHPbenP+TWBKcRHt +iMTwLLsCn9OmTeVL17gWg8MestfRONbDFYIFZHKrkrBybo0hLVHtmQQ36rgNAXamHluToNxC +0493jqvqVTGBadeeOl/RmiMEqBxiavv495JvY5997Ps6tpxj37exzw9iyzT2fYot59hyFbuB +925WyGhP2pf8EeIzZMW0YLBNN8wTBLVBuKUItxXC0mgjRYaxR1tovCaE2RK3979Q+k9CW7bq ++RZ4gZPIq4KfXCAY6p62qPzd9lYTyksgCM0NplXxNV7wSjsOMkH064eYwTIktcVMtvKN9pJc +XoY4xNfhEJ+GA1cw2BZTew7S/STdR2ka8sHM4yedlShbxqZ5mJlUf1KJSjwpvXl5uAjH2ZhE +PODMHfyWr8xui0lpDD03mmWU5Tzf0KORFC4Z4nZ466k/YA3Cz09gmvk7YQ1A21G6H91PcDLu +C/yNuwU5tEY9tu2S7vvR6JQDFHQjBSmRwobh6apoIhP+seToXEhqkrukGSneb5jcluEuKdqb +Ch0g9UkK8q/qwalOrlQLXpmR5qpQHWegE66SwB026tlauiEuldaT+fC2cEmX1Uh09YOuHzM8 +o5ZXJ9GGmcgTjpyu4fcj77nEFna/wx+8h4EfG9o45f3pmTugRH7A/WIeYCaSehge0nthuYnH +2PGeTmarKfxtVmQYsuJC8qTG/hfDl/Mf diff --git a/collects/lang/info.ss b/collects/lang/info.ss index 1a57d67828..f6eaf6a761 100644 --- a/collects/lang/info.ss +++ b/collects/lang/info.ss @@ -8,6 +8,9 @@ (define tool-names (list "How to Design Programs")) (define tool-urls (list "http://www.htdp.org/")) +(define compile-omit-paths + '("test-error.ss")) + (define textbook-pls (list (list '("htdp-icon.gif" "icons") "How to Design Programs" diff --git a/collects/lang/private/TODO b/collects/lang/private/TODO index 7f7f0cfc8b..c12461914a 100644 --- a/collects/lang/private/TODO +++ b/collects/lang/private/TODO @@ -38,4 +38,3 @@ string-ref : String Nat -> Char NOTE: substring consumes 2 or 3 arguments - diff --git a/collects/lang/private/teachprims.ss b/collects/lang/private/teachprims.ss index 6a2b3d0159..e1ab3aa309 100644 --- a/collects/lang/private/teachprims.ss +++ b/collects/lang/private/teachprims.ss @@ -192,8 +192,25 @@ namespace. (apply append x))))) (define-teach beginner error + (lambda stuff0 + (define-values (f stuff1) + (if (and (cons? stuff0) (symbol? (first stuff0))) + (values (first stuff0) (rest stuff0)) + (values false stuff0))) + (define str + (let loop ([stuff stuff1][frmt ""][pieces '()]) + (cond + [(empty? stuff) (apply format frmt (reverse pieces))] + [else + (let ([f (first stuff)] + [r (rest stuff)]) + (if (string? f) + (loop r (string-append frmt f) pieces) + (loop r (string-append frmt "~e") (cons f pieces))))]))) + (if f (error f str) (error str))) + #; (lambda (str) - (unless (string? str) + (unless (string? str) (raise (make-exn:fail:contract (format "error: expected a string, got ~e and ~e" str) diff --git a/collects/lang/test-error.ss b/collects/lang/test-error.ss new file mode 100644 index 0000000000..a2a20deb2f --- /dev/null +++ b/collects/lang/test-error.ss @@ -0,0 +1,16 @@ +;; The first three lines of this file were inserted by DrScheme. They record metadata +;; about the language level of this file in a form that our tools can easily process. +#reader(lib "htdp-beginner-reader.ss" "lang")((modname bar) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ()))) +(check-error (error) "") +(check-error (error 1) "1") +(check-error (error 'a) "a: ") +(check-error (error 'a "bad input") "a: bad input") +(check-error (error 'a "bad input: " 1) "a: bad input: 1") +(check-error (error 'a "bad input: " 1 " and " "hello") "a: bad input: 1 and hello") +(check-error (error 'a "bad input: " 1 " and " false) "a: bad input: 1 and false") +(check-error (error 'a "uhoh " (list 1 2 3)) "a: uhoh (cons 1 (cons 2 (cons 3 empty)))") + +(define-struct err (str)) + +(check-error (error 'a "bad input: " 1 " and " (make-err "hello")) + "a: bad input: 1 and (make-err \"hello\")") diff --git a/collects/lazy/lazy.scrbl b/collects/lazy/lazy.scrbl index e5d13c248e..b27d8056ec 100644 --- a/collects/lazy/lazy.scrbl +++ b/collects/lazy/lazy.scrbl @@ -1,7 +1,8 @@ #lang scribble/doc @(require (for-label (except-in lazy delay force) (only-in lazy/force ! !! !list !!list) - scheme/contract)) + scheme/contract + (only-in scheme/promise promise?))) @(define-syntax-rule (deflazy mod def id) (begin diff --git a/collects/macro-debugger/syntax-browser/text.ss b/collects/macro-debugger/syntax-browser/text.ss index d492aa859d..335f1206a8 100644 --- a/collects/macro-debugger/syntax-browser/text.ss +++ b/collects/macro-debugger/syntax-browser/text.ss @@ -285,7 +285,7 @@ (send dc set-text-foreground color) (send dc draw-text "?" (+ endx dx fw) - (- endy dy fh)))))))]) + (- (+ endy dy) fh)))))))]) (add-mouse-drawing from1 from2 draw tack-box) (add-mouse-drawing to1 to2 draw tack-box)))) diff --git a/collects/mrlib/image-core.ss b/collects/mrlib/image-core.ss index 8f77c5b7b6..d216c6dfc3 100644 --- a/collects/mrlib/image-core.ss +++ b/collects/mrlib/image-core.ss @@ -626,21 +626,23 @@ the mask bitmap and the original bitmap are all together in a single bytes! [orig-h (send orig-bm get-height)] [x-scale (bitmap-x-scale bitmap)] [y-scale (bitmap-y-scale bitmap)] - [scale-w (* x-scale (send orig-bm get-width))] - [scale-h (* y-scale (send orig-bm get-height))] + [scale-w (ceiling (inexact->exact (* x-scale (send orig-bm get-width))))] + [scale-h (ceiling (inexact->exact (* y-scale (send orig-bm get-height))))] [new-bm (make-object bitmap% scale-w scale-h)] - [new-mask (make-object bitmap% scale-w scale-h)]) - (send new-bm set-loaded-mask new-mask) + [new-mask (and orig-mask (make-object bitmap% scale-w scale-h))]) + (when new-mask + (send new-bm set-loaded-mask new-mask)) (send bdc set-bitmap new-bm) (send bdc set-scale x-scale y-scale) (send bdc clear) (send bdc draw-bitmap orig-bm 0 0) - (send bdc set-bitmap new-mask) - (send bdc set-scale x-scale y-scale) - (send bdc clear) - (send bdc draw-bitmap orig-mask 0 0) + (when new-mask + (send bdc set-bitmap new-mask) + (send bdc set-scale x-scale y-scale) + (send bdc clear) + (send bdc draw-bitmap orig-mask 0 0)) (send bdc set-bitmap #f) @@ -734,6 +736,6 @@ the mask bitmap and the original bitmap are all together in a single bytes! render-image) ;; method names -(provide get-shape get-bb get-normalized?) +(provide get-shape get-bb get-normalized? get-normalized-shape) (provide np-atomic-shape? atomic-shape? simple-shape?) diff --git a/collects/mrlib/private/image-core-bitmap.ss b/collects/mrlib/private/image-core-bitmap.ss index 7491cb4f9d..112af70085 100644 --- a/collects/mrlib/private/image-core-bitmap.ss +++ b/collects/mrlib/private/image-core-bitmap.ss @@ -59,8 +59,8 @@ instead of this scaling code, we use the dc<%>'s scaling code. [h (send bm get-height)] [bytes (make-bytes (* w h NUM-CHANNELS) 0)]) (send bm get-argb-pixels 0 0 w h bytes #f) - (when (send bm get-loaded-mask) - (send (send bm get-loaded-mask) get-argb-pixels 0 0 w h bytes #t)) + (when mask + (send mask get-argb-pixels 0 0 w h bytes #t)) (values bytes w h))) (define (bytes->bitmap bytes w h) diff --git a/collects/mzlib/compile.ss b/collects/mzlib/compile.ss index 45e24bab81..db8ecc77c1 100644 --- a/collects/mzlib/compile.ss +++ b/collects/mzlib/compile.ss @@ -1,57 +1,63 @@ +#lang scheme/base +(require scheme/function + scheme/path + scheme/file) +(provide compile-file) -(module compile mzscheme - (require "file.ss" - "port.ss") - (provide compile-file) - - ;; (require compiler/src2src) - - (define compile-file - (case-lambda - [(src) - (let-values ([(base name dir?) (split-path src)]) - (let ([cdir (build-path - (if (symbol? base) - 'same - base) - "compiled")]) - (unless (directory-exists? cdir) - (make-directory cdir)) - (compile-file src (build-path cdir (path-add-suffix name #".zo")))))] - [(src dest) (compile-file src dest values)] - [(src dest filter) - (let ([in (open-input-file src)]) - (dynamic-wind - void - (lambda () - (port-count-lines! in) - (with-handlers ([void - (lambda (exn) - (with-handlers ([void void]) - (delete-file dest)) - (raise exn))]) - (let ([out (open-output-file dest 'truncate/replace)] - [ok? #f]) - (let ([dir (let-values ([(base name dir?) (split-path src)]) - (if (eq? base 'relative) - (current-directory) - (path->complete-path base (current-directory))))]) - (parameterize ([current-load-relative-directory dir] - [current-write-relative-directory dir]) - (dynamic-wind - void - (lambda () - (let loop () - (let ([r (read-syntax src in)]) - (unless (eof-object? r) - (write (compile-syntax (filter (namespace-syntax-introduce r))) out) - (loop)))) - (set! ok? #t)) - (lambda () - (close-output-port out) - (unless ok? - (with-handlers ([void void]) - (delete-file dest)))))))))) - (lambda () (close-input-port in)))) - dest]))) +(define compile-file + (case-lambda + [(src) + (define cdir (build-path (path-only src) "compiled")) + (make-directory* cdir) + (compile-file src (build-path cdir (path-add-suffix (file-name-from-path src) #".zo")))] + [(src dest) + (compile-file src dest values)] + [(src dest filter) + (define in (open-input-file src)) + (dynamic-wind + void + (lambda () + (define ok? #f) + ; This must be based on the path to dest. Renaming typically cannot be done + ; atomically across file systems, so the temporary directory is not an option + ; because it is often a ram disk. src (or dir below) couldn't be used because + ; it may be on a different filesystem. Since dest must be a file path, this + ; guarantees that the temp file is in the same directory. It would take a weird + ; filesystem configuration to break that. + (define temp-filename (make-temporary-file "tmp~a" #f (path-only dest))) + (port-count-lines! in) + (dynamic-wind + void + (lambda () + ; XXX: This seems like it should be a library function named 'relative-path-only' + (define dir + (let-values ([(base name dir?) (split-path src)]) + (if (eq? base 'relative) + (current-directory) + (path->complete-path base (current-directory))))) + (define out (open-output-file temp-filename #:exists 'truncate/replace)) + (parameterize ([current-load-relative-directory dir] + [current-write-relative-directory dir]) + ; Rather than installing a continuation barrier, we detect reinvocation. + ; The only thing that can cause reinvocation is if the filter captures the + ; continuation and communicates it externally. + (define count 0) + (dynamic-wind + (lambda () + (if (zero? count) + (set! count 1) + (error 'compile-file "filter function should not be re-entrant"))) + (lambda () + (for ([r (in-port (curry read-syntax src) in)]) + (write (compile-syntax (filter (namespace-syntax-introduce r))) out)) + (set! ok? #t)) + (lambda () + (close-output-port out))))) + (lambda () + (if ok? + (rename-file-or-directory temp-filename dest) + (with-handlers ([exn:fail:filesystem? void]) + (delete-file temp-filename)))))) + (lambda () (close-input-port in))) + dest])) diff --git a/collects/planet/lang/reader.ss b/collects/planet/lang/reader.ss index 95d632e2dd..09a8aaf71c 100644 --- a/collects/planet/lang/reader.ss +++ b/collects/planet/lang/reader.ss @@ -6,13 +6,14 @@ [planet-get-info get-info])) (define-values (planet-read planet-read-syntax planet-get-info) - (make-meta-reader 'planet - "planet path" - (lambda (str) - (let ([str (bytes->string/latin-1 str)]) - (if (module-path? `(planet ,(string->symbol str))) - `(planet ,(string->symbol (string-append str "/lang/reader"))) - #f))) - values - values - values))) + (make-meta-reader + 'planet + "planet path" + (lambda (str) + (let ([str (bytes->string/latin-1 str)]) + (if (module-path? `(planet ,(string->symbol str))) + `(planet ,(string->symbol (string-append str "/lang/reader"))) + #f))) + values + values + values))) diff --git a/collects/reader/lang/reader.ss b/collects/reader/lang/reader.ss index 1c8ebd8c14..1473e045f9 100644 --- a/collects/reader/lang/reader.ss +++ b/collects/reader/lang/reader.ss @@ -6,11 +6,11 @@ [-get-info get-info])) (define-values (-read -read-syntax -get-info) - (make-meta-reader 'reader - "language path" - #:read-spec (lambda (in) (read in)) - (lambda (s) - (and (module-path? s) s)) - values - values - values))) + (make-meta-reader + 'reader + "language path" + #:read-spec (lambda (in) (read in)) + (lambda (s) (and (module-path? s) s)) + values + values + values))) diff --git a/collects/redex/private/matcher.ss b/collects/redex/private/matcher.ss index 96bd946974..6e9a2beff3 100644 --- a/collects/redex/private/matcher.ss +++ b/collects/redex/private/matcher.ss @@ -712,12 +712,6 @@ before the pattern compiler is invoked. [(has-underscore? pattern) (let*-values ([(binder before-underscore) (let ([before (split-underscore pattern)]) - (unless (or (hash-maps? clang-ht before) - (memq before underscore-allowed)) - (error 'compile-pattern "before underscore must be either a non-terminal ~a or a built-in pattern, found ~a in ~s" - before - (format "~s" (list* 'one 'of: (hash-map clang-ht (λ (x y) x)))) - pattern)) (values pattern before))] [(match-raw-name has-hole?) (compile-id-pattern before-underscore)]) diff --git a/collects/redex/private/rewrite-side-conditions.ss b/collects/redex/private/rewrite-side-conditions.ss index 4f853a95fe..e0db2ae638 100644 --- a/collects/redex/private/rewrite-side-conditions.ss +++ b/collects/redex/private/rewrite-side-conditions.ss @@ -1,4 +1,4 @@ -(module rewrite-side-conditions scheme/base +(module rewrite-side-conditions scheme (require (lib "list.ss") "underscore-allowed.ss") (require (for-template @@ -74,6 +74,20 @@ [(cross a) #`(cross #,(loop #'a))] [(cross a ...) (expected-exact 'cross 1 term)] [cross (expected-arguments 'cross term)] + [_ + (identifier? term) + (match (regexp-match #rx"^([^_]*)_.*" (symbol->string (syntax-e term))) + [(list _ (app string->symbol s)) + (if (or (memq s (cons '... underscore-allowed)) + (memq s all-nts)) + term + (raise-syntax-error + what + (format "before underscore must be either a non-terminal or a built-in pattern, found ~a in ~s" + s (syntax-e term)) + orig-stx + term))] + [_ term])] [(terms ...) (map loop (syntax->list (syntax (terms ...))))] [else diff --git a/collects/redex/private/term-test.ss b/collects/redex/private/term-test.ss index fa35933612..25059c7bbf 100644 --- a/collects/redex/private/term-test.ss +++ b/collects/redex/private/term-test.ss @@ -1,9 +1,7 @@ (module term-test scheme (require "term.ss" "matcher.ss" - "test-util.ss" - errortrace/errortrace-lib - errortrace/errortrace-key) + "test-util.ss") (reset-count) (test (term 1) 1) @@ -105,58 +103,75 @@ (define-namespace-anchor here) (define ns (namespace-anchor->namespace here)) - (define (runtime-error-source sexp src) - (let/ec return - (cadar - (continuation-mark-set->list - (exn-continuation-marks - (with-handlers ((exn:fail? values)) - (parameterize ([current-namespace ns]) - (parameterize ([current-compile (make-errortrace-compile-handler)]) - (eval (read-syntax src (open-input-string (format "~s" sexp)))))) - (return 'no-source))) - errortrace-key)))) - (let ([src 'term-template]) (test - (runtime-error-source - '(term-let ([(x ...) '(a b c)] - [((y ...) ...) '((1 2) (4 5 6) (7 8 9))]) - (term (((x y) ...) ...))) - src) + (parameterize ([current-namespace ns]) + (runtime-error-source + '(term-let ([(x ...) '(a b c)] + [((y ...) ...) '((1 2) (4 5 6) (7 8 9))]) + (term (((x y) ...) ...))) + src)) src)) (let ([src 'term-template-metafunc]) (test - (runtime-error-source - '(term-let-fn ((f car)) - (term-let ([(x ...) '(a b c)] - [((y ...) ...) '((1 2) (4 5 6) (7 8 9))]) - (term ((((f x) y) ...) ...)))) - src) + (parameterize ([current-namespace ns]) + (runtime-error-source + '(term-let-fn ((f car)) + (term-let ([(x ...) '(a b c)] + [((y ...) ...) '((1 2) (4 5 6) (7 8 9))]) + (term ((((f x) y) ...) ...)))) + src)) + src)) + + (let ([src 'ellipsis-args]) + (test + (parameterize ([current-namespace ns]) + (runtime-error-source + '(term-let-fn ((f car)) + (term-let ([(x ...) '(a b)] + [(y ...) '(c d e)]) + (term (f ((x y) ...))))) + src)) + src)) + + (let ([src 'ellipsis-args/map]) + (test + (parameterize ([current-namespace ns]) + (runtime-error-source + '(term-let-fn ((f car)) + (term-let ([(x ...) '(a b)] + [(y ...) '(c d e)]) + (term ((f (x y)) ...)))) + src)) + src)) + + (let ([src 'ellipsis-args/in-hole]) + (test + (parameterize ([current-namespace ns]) + (runtime-error-source + '(term-let ([(x ...) '(a b)] + [(y ...) '(c d e)]) + (term ((in-hole hole (x y)) ...))) + src)) src)) (let ([src 'term-let-rhs]) (test - (runtime-error-source - '(term-let ([(x ...) 'a]) - 3) - src) + (parameterize ([current-namespace ns]) + (runtime-error-source + '(term-let ([(x ...) 'a]) + 3) + src)) src)) - (define (syntax-error-sources sexp src) - (let ([p (read-syntax src (open-input-string (format "~s" sexp)))]) - (with-handlers ((exn:srclocs? (λ (x) (map srcloc-source ((exn:srclocs-accessor x) x))))) - (parameterize ([current-namespace ns]) - (expand p)) - null))) - (let ([src 'term-template]) (test - (syntax-error-sources - '(term-let ([(x ...) '(a b c)]) - (term x)) - src) + (parameterize ([current-namespace ns]) + (syntax-error-sources + '(term-let ([(x ...) '(a b c)]) + (term x)) + src)) (list src))) (print-tests-passed 'term-test.ss)) diff --git a/collects/redex/private/term.ss b/collects/redex/private/term.ss index 04c0f32927..bda4c28747 100644 --- a/collects/redex/private/term.ss +++ b/collects/redex/private/term.ss @@ -32,11 +32,11 @@ (let ([result-id (car (generate-temporaries '(f-results)))]) (with-syntax ([fn fn]) (let loop ([func (syntax (λ (x) (fn (syntax->datum x))))] - [args rewritten] + [args-stx rewritten] [res result-id] [args-depth (min depth max-depth)]) (with-syntax ([func func] - [args args] + [args args-stx] [res res]) (if (zero? args-depth) (begin @@ -45,7 +45,7 @@ outer-bindings)) (values result-id (min depth max-depth))) (loop (syntax (λ (l) (map func (syntax->list l)))) - (syntax (args (... ...))) + (syntax/loc args-stx (args (... ...))) (syntax (res (... ...))) (sub1 args-depth))))))))) @@ -55,7 +55,7 @@ (and (identifier? (syntax metafunc-name)) (term-fn? (syntax-local-value (syntax metafunc-name) (λ () #f)))) (rewrite-application (term-fn-get-id (syntax-local-value/catch (syntax metafunc-name) (λ (x) #t))) - (syntax (arg ...)) + (syntax/loc stx (arg ...)) depth)] [f (and (identifier? (syntax f)) @@ -76,7 +76,7 @@ [(unquote-splicing . x) (raise-syntax-error 'term "malformed unquote splicing" orig-stx stx)] [(in-hole id body) - (rewrite-application (syntax (λ (x) (apply plug x))) (syntax (id body)) depth)] + (rewrite-application (syntax (λ (x) (apply plug x))) (syntax/loc stx (id body)) depth)] [(in-hole . x) (raise-syntax-error 'term "malformed in-hole" orig-stx stx)] [hole (values (syntax (unsyntax the-hole)) 0)] diff --git a/collects/redex/private/test-util.ss b/collects/redex/private/test-util.ss index e973b69762..283a6596a0 100644 --- a/collects/redex/private/test-util.ss +++ b/collects/redex/private/test-util.ss @@ -1,10 +1,13 @@ #lang scheme -(require "matcher.ss") +(require "matcher.ss" + errortrace/errortrace-lib + errortrace/errortrace-key) (provide test test-syn-err tests reset-count syn-err-test-namespace print-tests-passed - equal/bindings?) + equal/bindings? + runtime-error-source syntax-error-sources) (define syn-err-test-namespace (make-base-namespace)) (parameterize ([current-namespace syn-err-test-namespace]) @@ -108,3 +111,20 @@ ;; rib-lt : rib rib -> boolean (define (rib-lt r1 r2) (string<=? (format "~s" (bind-name r1)) (format "~s" (bind-name r2)))) + +(define (runtime-error-source sexp src) + (let/ec return + (cadar + (continuation-mark-set->list + (exn-continuation-marks + (with-handlers ((exn:fail? values)) + (parameterize ([current-compile (make-errortrace-compile-handler)]) + (eval (read-syntax src (open-input-string (format "~s" sexp))))) + (return 'no-source))) + errortrace-key)))) + +(define (syntax-error-sources sexp src) + (let ([p (read-syntax src (open-input-string (format "~s" sexp)))]) + (with-handlers ((exn:srclocs? (λ (x) (map srcloc-source ((exn:srclocs-accessor x) x))))) + (expand p) + null))) \ No newline at end of file diff --git a/collects/redex/private/tl-test.ss b/collects/redex/private/tl-test.ss index e6c82aa862..d59d570d7c 100644 --- a/collects/redex/private/tl-test.ss +++ b/collects/redex/private/tl-test.ss @@ -261,7 +261,16 @@ (term (f 1))) (test rhs-eval-count 2)) + (define-namespace-anchor here) + (define ns (namespace-anchor->namespace here)) + (let ([src 'bad-underscore]) + (test + (parameterize ([current-namespace ns]) + (syntax-error-sources + '(define-language L (n m_1)) + src)) + (list src))) ; ; diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl index 1988cd8f2e..f53615be1c 100644 --- a/collects/redex/redex.scrbl +++ b/collects/redex/redex.scrbl @@ -128,7 +128,7 @@ in the grammar are terminals. @itemize[ -@item{The @defpattech[any] @pattern matches any sepxression. +@item{The @defpattech[any] @pattern matches any sexpression. This @pattern may also be suffixed with an underscore and another identifier, in which case they bind the full name (as if it were an implicit @pattech[name] @pattern) and match the portion @@ -192,9 +192,9 @@ symbol except those that are used as literals elsewhere in the language. } -@item{The @defpattech[hole] @pattern matches anything when inside a matching +@item{The @defpattech[hole] @pattern matches anything when inside the first argument to an @pattech[in-hole] @|pattern|. Otherwise, -it matches only the hole. +it matches only a hole. } @item{The @defpattech[symbol] @pattern stands for a literal symbol that must diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 05e586528c..f041ff174f 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "23nov2009") +#lang scheme/base (provide stamp) (define stamp "9dec2009") diff --git a/collects/scheme/contract/private/guts.ss b/collects/scheme/contract/private/guts.ss index 96e85aac05..cf5e50b4f6 100644 --- a/collects/scheme/contract/private/guts.ss +++ b/collects/scheme/contract/private/guts.ss @@ -66,9 +66,14 @@ (define-values (flat-prop flat-pred? flat-get) (make-struct-type-property 'contract-flat)) -(define-values (first-order-prop first-order-pred? first-order-get) +(define-values (first-order-prop first-order-pred? raw-first-order-get) (make-struct-type-property 'contract-first-order)) +(define (first-order-get stct) + (cond + [(flat-pred? stct) (flat-get stct)] + [else (raw-first-order-get stct)])) + (define (contract-first-order-passes? c v) (let ([ctc (coerce-contract 'contract-first-order-passes? c)]) (cond @@ -404,7 +409,8 @@ #:property name-prop (λ (ctc) (apply build-compound-type-name 'and/c (and/c-ctcs ctc))) #:property first-order-prop (λ (ctc) - (let ([tests (map (λ (x) ((first-order-get x) x)) (and/c-ctcs ctc))]) + (let ([tests (map (λ (x) ((first-order-get x) x)) + (and/c-ctcs ctc))]) (λ (x) (andmap (λ (f) (f x)) tests)))) #:property stronger-prop diff --git a/collects/scheme/contract/private/opt-guts.ss b/collects/scheme/contract/private/opt-guts.ss index d7efff5ecc..1dedd43c54 100644 --- a/collects/scheme/contract/private/opt-guts.ss +++ b/collects/scheme/contract/private/opt-guts.ss @@ -56,8 +56,14 @@ ;; struct for color-keeping across opters -(define-struct opt/info (contract val pos neg src-info orig-str positive-position? - free-vars recf base-pred this that)) +(define-struct opt/info + (contract val pos neg src-info orig-str position-var position-swap? + free-vars recf base-pred this that)) + +(define (opt/info-positive-position? oi) + (if (opt/info-position-swap? oi) + #`(not #,(opt/info-position-var oi)) + (opt/info-position-var oi))) ;; opt/info-swap-blame : opt/info -> opt/info ;; swaps pos and neg @@ -66,7 +72,8 @@ (val (opt/info-val info)) (pos (opt/info-pos info)) (neg (opt/info-neg info)) - (positive-position? (opt/info-positive-position? info)) + (position-var (opt/info-position-var info)) + (position-swap? (opt/info-position-swap? info)) (src-info (opt/info-src-info info)) (orig-str (opt/info-orig-str info)) (free-vars (opt/info-free-vars info)) @@ -74,7 +81,8 @@ (base-pred (opt/info-base-pred info)) (this (opt/info-this info)) (that (opt/info-that info))) - (make-opt/info ctc val neg pos src-info orig-str (not positive-position?) + (make-opt/info ctc val neg pos src-info orig-str + position-var (not position-swap?) free-vars recf base-pred this that))) ;; opt/info-change-val : identifier opt/info -> opt/info @@ -83,7 +91,8 @@ (let ((ctc (opt/info-contract info)) (pos (opt/info-pos info)) (neg (opt/info-neg info)) - (positive-position? (opt/info-positive-position? info)) + (position-var (opt/info-position-var info)) + (position-swap? (opt/info-position-swap? info)) (src-info (opt/info-src-info info)) (orig-str (opt/info-orig-str info)) (free-vars (opt/info-free-vars info)) @@ -91,7 +100,9 @@ (base-pred (opt/info-base-pred info)) (this (opt/info-this info)) (that (opt/info-that info))) - (make-opt/info ctc val pos neg src-info orig-str positive-position? free-vars recf base-pred this that))) + (make-opt/info ctc val pos neg src-info orig-str + position-var position-swap? + free-vars recf base-pred this that))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/collects/scheme/contract/private/opt.ss b/collects/scheme/contract/private/opt.ss index d0383f4920..888b11c84c 100644 --- a/collects/scheme/contract/private/opt.ss +++ b/collects/scheme/contract/private/opt.ss @@ -127,6 +127,7 @@ #'src-info #'orig-str #'positive-position? + #f (syntax->list #'(opt-recursive-args ...)) #f #f diff --git a/collects/scheme/foreign.ss b/collects/scheme/foreign.ss index 66e3d94127..7045d05b36 100644 --- a/collects/scheme/foreign.ss +++ b/collects/scheme/foreign.ss @@ -1,7 +1,7 @@ #lang scheme/base ;; Foreign Scheme interface -(require '#%foreign setup/dirs +(require '#%foreign setup/dirs scheme/unsafe/ops (for-syntax scheme/base scheme/list syntax/stx)) ;; This module is full of unsafe bindings that are not provided to requiring @@ -1081,7 +1081,8 @@ [TAG-set! (id "" "-set!")] [_TAG (id "_" "")] [_TAG* (id "_" "*")] - [TAGname name]) + [TAGname name] + [f64? (if (eq? (syntax-e #'TAG) 'f64) #'#t #'#f)]) #'(begin (define-struct TAG (ptr length)) (provide TAG? TAG-length (rename-out [TAG s:TAG])) @@ -1102,14 +1103,19 @@ (define* (TAG-ref v i) (if (TAG? v) (if (and (exact-nonnegative-integer? i) (< i (TAG-length v))) - (ptr-ref (TAG-ptr v) type i) + (if f64? ;; use JIT-inlined operation + (unsafe-f64vector-ref v i) + (ptr-ref (TAG-ptr v) type i)) (error 'TAG-ref "bad index ~e for ~a bounds of 0..~e" i 'TAG (sub1 (TAG-length v)))) (raise-type-error 'TAG-ref TAGname v))) (define* (TAG-set! v i x) (if (TAG? v) (if (and (exact-nonnegative-integer? i) (< i (TAG-length v))) - (ptr-set! (TAG-ptr v) type i x) + (if (and f64? ;; use JIT-inlined operation + (inexact-real? x)) + (unsafe-f64vector-set! v i x) + (ptr-set! (TAG-ptr v) type i x)) (error 'TAG-set! "bad index ~e for ~a bounds of 0..~e" i 'TAG (sub1 (TAG-length v)))) (raise-type-error 'TAG-set! TAGname v))) @@ -1264,9 +1270,10 @@ (raise-type-error 'cast "ctype" to-type)) (unless (= (ctype-sizeof to-type) (ctype-sizeof from-type)) - (raise-mismatch-error (format "representation sizes of types differ: ~e to " - from-type) - to-type)) + (raise-mismatch-error 'cast + (format "representation sizes of from and to types differ: ~e and " + (ctype-sizeof from-type)) + (ctype-sizeof to-type))) (let ([p2 (malloc from-type)]) (ptr-set! p2 from-type p) (ptr-ref p2 to-type))) diff --git a/collects/scheme/mzscheme.ss b/collects/scheme/mzscheme.ss index a5d78c657f..fff161e0c4 100644 --- a/collects/scheme/mzscheme.ss +++ b/collects/scheme/mzscheme.ss @@ -16,7 +16,7 @@ "private/old-procs.ss" "private/map.ss" ; shadows #%kernel bindings "private/kernstruct.ss" - "promise.ss" + "private/promise.ss" (only "private/cond.ss" old-cond) "tcp.ss" "udp.ss" diff --git a/collects/scheme/package.ss b/collects/scheme/package.ss index 167c2c45dc..3052588932 100644 --- a/collects/scheme/package.ss +++ b/collects/scheme/package.ss @@ -317,9 +317,11 @@ (let* ([def-ctx (if star? (syntax-local-make-definition-context (car def-ctxes)) (last def-ctxes))] - [ids (if star? - (map (add-package-context (list def-ctx)) ids) - ids)]) + [ids (map + (lambda (id) (syntax-property id 'unshadowable #t)) + (if star? + (map (add-package-context (list def-ctx)) ids) + ids))]) (syntax-local-bind-syntaxes ids #'rhs def-ctx) (register-bindings! ids) (loop (cdr exprs) @@ -335,9 +337,11 @@ (let* ([def-ctx (if star? (syntax-local-make-definition-context (car def-ctxes)) (last def-ctxes))] - [ids (if star? - (map (add-package-context (list def-ctx)) ids) - ids)]) + [ids (map + (lambda (id) (syntax-property id 'unshadowable #t)) + (if star? + (map (add-package-context (list def-ctx)) ids) + ids))]) (syntax-local-bind-syntaxes ids #f def-ctx) (register-bindings! ids) (loop (cdr exprs) diff --git a/collects/scheme/private/at-syntax.ss b/collects/scheme/private/at-syntax.ss deleted file mode 100644 index 4753d40918..0000000000 --- a/collects/scheme/private/at-syntax.ss +++ /dev/null @@ -1,71 +0,0 @@ -#lang scheme/base - -(require (for-template scheme/base)) - -(provide at-syntax) - -;; ------------------------------------------------------------------- -;; NOTE: This library is for internal use only, it is can change -;; and/or disappear. Do not use without protective eyewear! -;; ------------------------------------------------------------------- - -#| - -The `(at-syntax expr)' form is a useful syntax-time utility that can -be used to sort of evaluate an expression at syntax time, and doing so -in a well behaved way (eg, it respects the source for-syntax bindings, -but it does have some issues). It can be used to implement an escape -to the syntax level that is not restricted like `begin-for-syntax'. - -The basic idea of the code is to plant the given expression on the -right hand side of a `let-syntax' -- inside a `(lambda (stx) ...)' to -make it a valid transformer, with a singe use of this macro so that we -get it to execute with `local-expand'. The macro returns a 3d -expression that contains the evaluated expression "somehwhere", -depending on the expansion of `let-syntax' -- so to make it easy to -find we plant it inside a thunk (so this works as long as `let-syntax' -does not include 3d procedure values in its expansion). Finally, the -constructed `let-syntax' is expanded, we search through the resulting -syntax for the thunk, then apply it to get the desired value. - -Here's a silly example to demonstrate: - - > (define-syntax (compile-time-if stx) - (syntax-case stx () - [(_ cond expr1 expr2) - (if (at-syntax #'cond) #'expr1 #'expr2)])) - > (define-for-syntax x 8) - > (define x 100) - > (compile-time-if (< x 10) (+ x 10) (- x 10)) - 110 - -And another example, creating a macro for syntax-time expressions: - - > (define-syntax (compile-time-value stx) - (syntax-case stx () - [(_ expr) #`(quote #,(at-syntax #'expr))])) - > (compile-time-value (* x 2)) - 16 - -but the `quote' here is a hint that this can get 3d values into -syntax, and all the problems that are involved. Also, note that it -breaks if you try to do something like: - - > (compile-time-value (begin (set! x 11) x)) - 8 - -(and, of course, it cannot be used to define new bindings). - -|# - -(define (at-syntax expr) - (let loop ([x (with-syntax ([e expr]) - (local-expand - #'(let-syntax ([here (lambda (stx) - (datum->syntax stx (lambda () e)))]) - here) - 'expression '()))]) - (cond [(procedure? x) (x)] - [(pair? x) (or (loop (car x)) (loop (cdr x)))] - [(syntax? x) (loop (syntax-e x))] - [else #f]))) diff --git a/collects/scheme/private/for.ss b/collects/scheme/private/for.ss index f34104146e..4041239658 100644 --- a/collects/scheme/private/for.ss +++ b/collects/scheme/private/for.ss @@ -469,8 +469,8 @@ (define in-port (case-lambda - [() (in-port (current-input-port) read)] - [(r) (in-port (current-input-port) r)] + [() (in-port read (current-input-port))] + [(r) (in-port r (current-input-port))] [(r p) (unless (and (procedure? r) (procedure-arity-includes? r 1)) (raise-type-error 'in-port "procedure (arity 1)" r)) diff --git a/collects/scheme/private/promise.ss b/collects/scheme/private/promise.ss new file mode 100644 index 0000000000..314f073e46 --- /dev/null +++ b/collects/scheme/private/promise.ss @@ -0,0 +1,269 @@ +(module promise '#%kernel +(#%require "small-scheme.ss" + "more-scheme.ss" + "define.ss" + (rename "define-struct.ss" define-struct define-struct*) + (for-syntax '#%kernel "stxcase-scheme.ss" "name.ss") + '#%unsafe) +(#%provide force promise? promise-forced? promise-running? + ;; provided to create extensions + (struct promise ()) pref pset! prop:force reify-result + promise-printer + (struct running ()) (struct reraise ()) + (for-syntax make-delayer)) + +;; This module implements "lazy" (composable) promises and a `force' +;; that is iterated through them. + +;; This is similar to the *new* version of srfi-45 -- see the +;; post-finalization discussion at http://srfi.schemers.org/srfi-45/ for +;; more details; specifically, this version is the `lazy2' version from +;; http://srfi.schemers.org/srfi-45/post-mail-archive/msg00013.html. +;; Note: if you use only `force'+`delay' it behaves as in Scheme (except +;; that `force' is identity for non promise values), and `force'+`lazy' +;; are sufficient for implementing the lazy language. + +;; unsafe accessors +(define-syntax pref (syntax-rules () [(_ p ) (unsafe-struct-ref p 0 )])) +(define-syntax pset! (syntax-rules () [(_ p x) (unsafe-struct-set! p 0 x)])) + +;; ---------------------------------------------------------------------------- +;; Forcers + +;; force/composable iterates on composable promises +;; * (force X) = X for non promises +;; * does not deal with multiple values in the composable case +(define (force/composable root) + (let ([v (pref root)]) + (cond + [(procedure? v) + ;; mark the root as running: avoids cycles, and no need to keep banging + ;; the root promise value; it makes this non-r5rs, but the only + ;; practical uses of these things could be ones that use state to avoid + ;; an infinite loop. (See the generic forcer below.) + ;; (careful: avoid holding a reference to the thunk, to allow + ;; safe-for-space loops) + (pset! root (make-running (object-name v))) + (call-with-exception-handler + (lambda (e) (pset! root (make-reraise e)) e) + (lambda () + ;; iterate carefully through chains of composable promises + (let loop ([v (v)]) ; does not handle multiple values! + (cond [(composable-promise? v) + (let ([v* (pref v)]) + (pset! v root) ; share with root + (cond [(procedure? v*) (loop (v*))] + ;; it must be a list of one value (because + ;; composable promises never hold multiple values), + ;; or a composable promise + [(pair? v*) (pset! root v*) (unsafe-car v*)] + ;; note: for the promise case we could jump only to + ;; the last `let' (for `v*'), but that makes the + ;; code heavier, and runs slower (probably goes over + ;; some inlining/unfolding threshold). + [else (loop v*)]))] + ;; reached a non-composable promise: share and force it now + [(promise? v) (pset! root v) (force v)] + ;; error here for "library approach" (see above URL) + [else (pset! root (list v)) v]))))] + ;; try to make the order efficient, with common cases first + [(pair? v) (if (null? (unsafe-cdr v)) (unsafe-car v) (apply values v))] + ;; follow all sharings (and shortcut directly to the right force) + [(composable-promise? v) (force/composable v) (force v)] + [(null? v) (values)] + [else (error 'force "composable promise with invalid contents: ~e" v)]))) + +(define (reify-result v) + (cond [(pair? v) (if (null? (unsafe-cdr v)) (unsafe-car v) (apply values v))] + [(null? v) (values)] + [(reraise? v) (v)] + [else (error 'force "promise with invalid contents: ~e" v)])) + +;; generic force for "old-style" promises -- they're still useful in +;; that they allow multiple values. In general, this is slower, but has +;; more features. (They could allow self loops, but this means holding +;; on to the procedure and its resources while it is running, and lose +;; the ability to know that it is running; the second can be resolved +;; with a new kind of `running' value that can be used again, but the +;; first cannot be solved. I still didn't ever see any use for them, so +;; they're still forbidden.) +(define (force/generic promise) + (reify-result + (let ([v (pref promise)]) + (if (procedure? v) + (begin + (pset! promise (make-running (object-name v))) + (call-with-exception-handler + (lambda (e) (pset! promise (make-reraise e)) e) + (lambda () + (let ([vs (call-with-values v list)]) (pset! promise vs) vs)))) + v)))) + +;; dispatcher for composable promises, generic promises, and other values +(define (force promise) + (if (promise? promise) + ((promise-forcer promise) promise) ; dispatch to specific forcer + promise)) ; different from srfi-45: identity for non-promises + +;; ---------------------------------------------------------------------------- +;; Struct definitions + +;; generic promise printer +(define (promise-printer promise port write?) + (let loop ([v (pref promise)]) + (cond + [(reraise? v) + (let ([r (reraise-val v)]) + (if (exn? r) + (fprintf port (if write? "#" "#") + (exn-message r)) + (fprintf port (if write? "#" "#") + r)))] + [(running? v) + (let ([r (running-name v)]) + (if r + (fprintf port "#" r) + (fprintf port "#")))] + [(procedure? v) + (cond [(object-name v) + => (lambda (n) (fprintf port "#" n))] + [else (display "#" port)])] + [(promise? v) (loop (pref v))] ; hide sharing + ;; values + [(null? v) (fprintf port "#")] + [(null? (cdr v)) + (fprintf port (if write? "#" "#") (car v))] + [else (display "#" port)]))) + +;; property value for the right forcer to use +(define-values [prop:force promise-forcer] + (let-values ([(prop pred? get) ; no need for the predicate + (make-struct-type-property 'forcer + (lambda (v info) + (unless (and (procedure? v) + (procedure-arity-includes? v 1)) + (raise-type-error 'prop:force "a unary function" v)) + v))]) + (values prop get))) + +;; A promise value can hold +;; - (list ...): forced promise (possibly multiple-values) +;; - composable promises deal with only one value +;; - : a shared (redirected) promise that points at another one +;; - possible only with composable promises +;; - : usually a delayed promise, +;; - can also hold a `running' thunk that will throw a reentrant error +;; - can also hold a raising-a-value thunk on exceptions and other +;; `raise'd values (actually, applicable structs for printouts) +;; First, a generic struct, which is used for all promise-like values +(define-struct promise ([val #:mutable]) + #:property prop:custom-write promise-printer + #:property prop:force force/generic) +;; Then, a subtype for composable promises +(define-struct (composable-promise promise) () + #:property prop:force force/composable) + +;; template for all delay-like constructs +;; (with simple keyword matching: keywords is an alist with default exprs) +(define-for-syntax (make-delayer stx maker keywords) + ;; no `cond', `and', `or', `let', `define', etc here + (letrec-values + ([(exprs+kwds) + (lambda (stxs exprs kwds) + (if (null? stxs) + (values (reverse exprs) (reverse kwds)) + (if (not (keyword? (syntax-e (car stxs)))) + (exprs+kwds (cdr stxs) (cons (car stxs) exprs) kwds) + (if (if (pair? (cdr stxs)) + (if (assq (syntax-e (car stxs)) keywords) + (not (assq (syntax-e (car stxs)) kwds)) + #f) + #f) + (exprs+kwds (cddr stxs) exprs + (cons (cons (syntax-e (car stxs)) (cadr stxs)) + kwds)) + (values #f #f)))))] + [(stxs) (syntax->list stx)] + [(exprs kwds) (exprs+kwds (if stxs (cdr stxs) '()) '() '())] + [(kwd-args) (if kwds + (map (lambda (k) + (let-values ([(x) (assq (car k) kwds)]) + (if x (cdr x) (cdr k)))) + keywords) + #f)] + ;; some strange bug with `syntax-local-expand-expression' makes this not + ;; work well with identifiers, so turn the name into a symbol to work + ;; around this for now + [(name0) (syntax-local-infer-name stx)] + [(name) (if (syntax? name0) (syntax-e name0) name0)]) + (syntax-case stx () + [_ (pair? exprs) ; throw a syntax error if anything is wrong + (with-syntax ([(expr ...) exprs] + [(kwd-arg ...) kwd-args]) + (with-syntax ([proc (syntax-property + (syntax/loc stx (lambda () expr ...)) + 'inferred-name name)] + [make maker]) + (syntax/loc stx (make proc kwd-arg ...))))]))) + +;; Creates a composable promise +;; 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 '())) + +;; Creates a (generic) promise that does not compose +;; X = (force (delay X)) = (force (lazy (delay X))) +;; = (force (lazy^n (delay X))) +;; X = (force (force (delay (delay X)))) != (force (delay (delay X))) +;; so each sequence of `(lazy^n o delay)^m' requires m `force's and a +;; sequence of `(lazy^n o delay)^m o lazy^k' requires m+1 `force's (for k>0) +;; (This is not needed with a lazy language (see the above URL for details), +;; but provided for regular delay/force uses.) +(#%provide (rename delay* delay)) +(define delay make-promise) +(define-syntax (delay* stx) (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 +;; way and test for them -- we just use a thunk that will raise the exception. +;; But it's still useful to refer to the exception value, so use an applicable +;; struct for them. The same goes for a promise that is being forced: we use a +;; thunk that will throw a "reentrant promise" error -- and use an applicable +;; struct so it is identifiable. +(define-struct reraise (val) + #:property prop:procedure (lambda (this) (raise (reraise-val this)))) +(define-struct running (name) + #:property prop:procedure (lambda (this) + (let ([name (running-name this)]) + (if name + (error 'force "reentrant promise ~e" name) + (error 'force "reentrant promise"))))) + +;; ---------------------------------------------------------------------------- +;; Utilities + +(define (promise-forced? promise) + (if (promise? promise) + (let ([v (pref promise)]) + (or (not (procedure? v)) (reraise? v))) ; #f when running + (raise-type-error 'promise-forced? "promise" promise))) + +(define (promise-running? promise) + (if (promise? promise) + (running? (pref promise)) + (raise-type-error 'promise-running? "promise" promise))) + +) + +#| +Simple code for timings: + (define (c n) (lazy (if (zero? n) (delay 'hey!) (c (sub1 n))))) + (for ([i (in-range 9)]) + (collect-garbage) (collect-garbage) (collect-garbage) + (time (for ([i (in-range 10000)]) (force (c 2000))))) +Also, run (force (c -1)) and check constant space +|# diff --git a/collects/scheme/private/sort.ss b/collects/scheme/private/sort.ss index 387560366c..a528b57ce9 100644 --- a/collects/scheme/private/sort.ss +++ b/collects/scheme/private/sort.ss @@ -76,14 +76,16 @@ doing these checks. (loop a1 b1 c1))))))))) (define-syntax-rule (copying-insertionsort Alo Blo n) - (let iloop ([i 0] [A Alo]) - (when (i< i n) - (let ([ref-i (ref A)]) - (let jloop ([j (i+ Blo i)]) - (let ([ref-j-1 (ref (i- j 1))]) - (if (and (i< Blo j) (" "#") - (exn-message r)) - (fprintf port (if write? "#" "#") - r)))] - [(running? v) - (let ([r (running-name v)]) - (if r - (fprintf port "#" r) - (fprintf port "#")))] - [(procedure? v) - (cond [(object-name v) - => (lambda (n) (fprintf port "#" n))] - [else (display "#" port)])] - [(promise? v) (loop (pref v))] ; hide sharing - ;; values - [(null? v) (fprintf port "#")] - [(null? (cdr v)) - (fprintf port (if write? "#" "#") (car v))] - [else (display "#" port)]))) - -;; property value for the right forcer to use -(define-values [prop:force promise-forcer] - (let-values ([(prop pred? get) ; no need for the predicate - (make-struct-type-property 'forcer - (lambda (v info) - (unless (and (procedure? v) - (procedure-arity-includes? v 1)) - (raise-type-error 'prop:force "a unary function" v)) - v))]) - (values prop get))) - -;; A promise value can hold -;; - (list ...): forced promise (possibly multiple-values) -;; - composable promises deal with only one value -;; - : a shared (redirected) promise that points at another one -;; - possible only with composable promises -;; - : usually a delayed promise, -;; - can also hold a `running' thunk that will throw a reentrant error -;; - can also hold a raising-a-value thunk on exceptions and other -;; `raise'd values (actually, applicable structs for printouts) -;; First, a generic struct, which is used for all promise-like values -(define-struct promise ([val #:mutable]) - #:property prop:custom-write promise-printer - #:property prop:force force/generic) -;; Then, a subtype for composable promises -(define-struct (composable-promise promise) () - #:property prop:force force/composable) - -;; template for all delay-like constructs -;; (with simple keyword matching: keywords is an alist with default exprs) -(define-for-syntax (make-delayer stx maker keywords) - ;; no `cond', `and', `or', `let', `define', etc here - (letrec-values - ([(exprs+kwds) - (lambda (stxs exprs kwds) - (if (null? stxs) - (values (reverse exprs) (reverse kwds)) - (if (not (keyword? (syntax-e (car stxs)))) - (exprs+kwds (cdr stxs) (cons (car stxs) exprs) kwds) - (if (if (pair? (cdr stxs)) - (if (assq (syntax-e (car stxs)) keywords) - (not (assq (syntax-e (car stxs)) kwds)) - #f) - #f) - (exprs+kwds (cddr stxs) exprs - (cons (cons (syntax-e (car stxs)) (cadr stxs)) - kwds)) - (values #f #f)))))] - [(stxs) (syntax->list stx)] - [(exprs kwds) (exprs+kwds (if stxs (cdr stxs) '()) '() '())] - [(kwd-args) (if kwds - (map (lambda (k) - (let-values ([(x) (assq (car k) kwds)]) - (if x (cdr x) (cdr k)))) - keywords) - #f)] - ;; some strange bug with `syntax-local-expand-expression' makes this not - ;; work well with identifiers, so turn the name into a symbol to work - ;; around this for now - [(name0) (syntax-local-infer-name stx)] - [(name) (if (syntax? name0) (syntax-e name0) name0)]) - (syntax-case stx () - [_ (pair? exprs) ; throw a syntax error if anything is wrong - (with-syntax ([(expr ...) exprs] - [(kwd-arg ...) kwd-args]) - (with-syntax ([proc (syntax-property - (syntax/loc stx (lambda () expr ...)) - 'inferred-name name)] - [make maker]) - (syntax/loc stx (make proc kwd-arg ...))))]))) - -;; Creates a composable promise -;; 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 '())) - -;; Creates a (generic) promise that does not compose -;; X = (force (delay X)) = (force (lazy (delay X))) -;; = (force (lazy^n (delay X))) -;; X = (force (force (delay (delay X)))) != (force (delay (delay X))) -;; so each sequence of `(lazy^n o delay)^m' requires m `force's and a -;; sequence of `(lazy^n o delay)^m o lazy^k' requires m+1 `force's (for k>0) -;; (This is not needed with a lazy language (see the above URL for details), -;; but provided for regular delay/force uses.) -(#%provide (rename delay* delay)) -(define delay make-promise) -(define-syntax (delay* stx) (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 -;; way and test for them -- we just use a thunk that will raise the exception. -;; But it's still useful to refer to the exception value, so use an applicable -;; struct for them. The same goes for a promise that is being forced: we use a -;; thunk that will throw a "reentrant promise" error -- and use an applicable -;; struct so it is identifiable. -(define-struct reraise (val) - #:property prop:procedure (lambda (this) (raise (reraise-val this)))) -(define-struct running (name) - #:property prop:procedure (lambda (this) - (let ([name (running-name this)]) - (if name - (error 'force "reentrant promise ~e" name) - (error 'force "reentrant promise"))))) - -;; ---------------------------------------------------------------------------- -;; Utilities - -(define (promise-forced? promise) - (if (promise? promise) - (let ([v (pref promise)]) - (or (not (procedure? v)) (reraise? v))) ; #f when running - (raise-type-error 'promise-forced? "promise" promise))) - -(define (promise-running? promise) - (if (promise? promise) - (running? (pref promise)) - (raise-type-error 'promise-running? "promise" promise))) +#lang scheme/base +(require "private/promise.ss" (for-syntax scheme/base)) +(provide delay lazy force promise? promise-forced? promise-running?) ;; ---------------------------------------------------------------------------- ;; More delay-like values, with different ways of deferring computations @@ -259,7 +8,7 @@ (define-struct (promise/name promise) () #:property prop:force (lambda (p) ((pref p)))) -(#%provide (rename delay/name* delay/name)) +(provide (rename-out [delay/name* delay/name])) (define delay/name make-promise/name) (define-syntax (delay/name* stx) (make-delayer stx #'delay/name '())) @@ -315,7 +64,7 @@ (let ([v (pref p)]) (handle-evt (if (syncinfo? v) (syncinfo-done-evt v) always-evt) void)))) -(#%provide (rename delay/sync* delay/sync)) +(provide (rename-out [delay/sync* delay/sync])) (define (delay/sync thunk) (let ([done-sema (make-semaphore 0)]) (make-promise/sync (make-syncinfo thunk @@ -339,7 +88,7 @@ (handle-evt (if (running? v) (running-thread-thread v) always-evt) void)))) -(#%provide (rename delay/thread* delay/thread)) +(provide (rename-out [delay/thread* delay/thread])) (define (delay/thread thunk group) (define (run) (call-with-exception-handler @@ -354,7 +103,7 @@ (thread run))))) p) (define-syntax delay/thread* - (let-values ([(kwds) (list (cons '#:group #'#t))]) + (let ([kwds (list (cons '#:group #'#t))]) (lambda (stx) (make-delayer stx #'delay/thread kwds)))) (define-struct (promise/idle promise/thread) () @@ -371,7 +120,7 @@ (pref p)) v))))) -(#%provide (rename delay/idle* delay/idle)) +(provide (rename-out [delay/idle* delay/idle])) (define (delay/idle thunk wait-for work-while tick use*) (define use (cond [(use* . <= . 0) 0] [(use* . >= . 1) 1] [else use*])) (define work-time (* tick use)) @@ -422,19 +171,8 @@ (or (object-name thunk) 'idle-thread)))) p) (define-syntax delay/idle* - (let-values ([(kwds) (list (cons '#:wait-for #'(system-idle-evt)) - (cons '#:work-while #'(system-idle-evt)) - (cons '#:tick #'0.2) - (cons '#:use #'0.12))]) + (let ([kwds (list (cons '#:wait-for #'(system-idle-evt)) + (cons '#:work-while #'(system-idle-evt)) + (cons '#:tick #'0.2) + (cons '#:use #'0.12))]) (lambda (stx) (make-delayer stx #'delay/idle kwds)))) - -) - -#| -Simple code for timings: - (define (c n) (lazy (if (zero? n) (delay 'hey!) (c (sub1 n))))) - (for ([i (in-range 9)]) - (collect-garbage) (collect-garbage) (collect-garbage) - (time (for ([i (in-range 10000)]) (force (c 2000))))) -Also, run (force (c -1)) and check constant space -|# diff --git a/collects/scheme/provide.ss b/collects/scheme/provide.ss index 9c4cd9b446..b3bdbd12f1 100644 --- a/collects/scheme/provide.ss +++ b/collects/scheme/provide.ss @@ -1,7 +1,7 @@ #lang scheme/base (require (for-syntax scheme/base scheme/provide-transform scheme/list - "private/at-syntax.ss")) + (only-in unstable/syntax syntax-local-eval))) (provide matching-identifiers-out) (define-syntax matching-identifiers-out @@ -21,7 +21,7 @@ (lambda (stx modes) (syntax-case stx () [(_ proc spec) - (let ([proc (at-syntax #'proc)]) + (let ([proc (syntax-local-eval #'proc)]) (filter-map (lambda (e) (let* ([s1 (symbol->string (export-out-sym e))] diff --git a/collects/scheme/require.ss b/collects/scheme/require.ss index 0349b3df30..b40197f910 100644 --- a/collects/scheme/require.ss +++ b/collects/scheme/require.ss @@ -1,7 +1,7 @@ #lang scheme/base (require (for-syntax scheme/base scheme/require-transform scheme/list - "private/at-syntax.ss") + (only-in unstable/syntax syntax-local-eval)) "require-syntax.ss") (provide matching-identifiers-in) @@ -43,7 +43,7 @@ (lambda (stx) (syntax-case stx () [(_ proc spec) - (let ([proc (at-syntax #'proc)]) + (let ([proc (syntax-local-eval #'proc)]) (define-values [imports sources] (expand-import #'spec)) (values (filter-map diff --git a/collects/scheme/signature/lang.ss b/collects/scheme/signature/lang.ss index 8635cae591..0752de7fe5 100644 --- a/collects/scheme/signature/lang.ss +++ b/collects/scheme/signature/lang.ss @@ -1,6 +1,7 @@ #lang scheme/base (require scheme/unit + scheme/contract (for-syntax scheme/base mzlib/private/unit-compiletime mzlib/private/unit-syntax)) @@ -8,6 +9,7 @@ (provide (rename-out [module-begin #%module-begin]) (except-out (all-from-out scheme/base) #%module-begin) (all-from-out scheme/unit) + (all-from-out scheme/contract) (for-syntax (all-from-out scheme/base))) (define-for-syntax (make-name s) diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss index 0acb2aff7b..5d89505c52 100644 --- a/collects/scribble/html-render.ss +++ b/collects/scribble/html-render.ss @@ -619,7 +619,7 @@ ,@(navigation d ri #t) ,@(render-part d ri) ,@(navigation d ri #f))) - (div ([id "langindicator"]) nbsp))))))))) + (div ([id "contextindicator"]) nbsp))))))))) (define/private (part-parent d ri) (collected-info-parent (part-collected-info d ri))) diff --git a/collects/scribble/lp-include.ss b/collects/scribble/lp-include.ss index dfc75496a8..f494e0dc47 100644 --- a/collects/scribble/lp-include.ss +++ b/collects/scribble/lp-include.ss @@ -7,14 +7,14 @@ (provide lp-include) (define-syntax (module stx) - (syntax-case stx () + (syntax-case stx (#%module-begin) + [(module name base (#%module-begin body ...)) + #'(begin body ...)] [(module name base body ...) - (begin - #'(begin body ...))])) + (raise-syntax-error #f "missing #%module-begin" stx)])) (define-syntax (lp-include stx) (syntax-case stx () [(_ name) (with-syntax ([there (datum->syntax stx 'there)]) #'(include-at/relative-to here there name))])) - diff --git a/collects/scribble/scribble-common.js b/collects/scribble/scribble-common.js index 13b1dfa07a..cc37899a09 100644 --- a/collects/scribble/scribble-common.js +++ b/collects/scribble/scribble-common.js @@ -1,5 +1,56 @@ // Common functionality for PLT documentation pages +// Page Parameters ------------------------------------------------------------ + +var page_query_string = + (location.href.search(/\?([^#]+)(?:#|$)/) >= 0) && RegExp.$1; + +var page_args = + ((function(){ + if (!page_query_string) return []; + var args = page_query_string.split(/[&;]/); + for (var i=0; i= 0) args[i] = [a.substring(0,p), a.substring(p+1)]; + else args[i] = [a, false]; + } + return args; + })()); + +function GetPageArg(key, def) { + for (var i=0; i _int) +] + +specifies a function that receives an integer and a +string, and returns an integer. + In its full form, the @scheme[_fun] syntax provides an IDL-like language that can be used to create a wrapper function around the primitive foreign function. These wrappers can implement complex diff --git a/collects/scribblings/futures/futures.scrbl b/collects/scribblings/futures/futures.scrbl index 3039ff4ff8..4241496097 100644 --- a/collects/scribblings/futures/futures.scrbl +++ b/collects/scribblings/futures/futures.scrbl @@ -7,35 +7,158 @@ @(require scribble/manual scribble/urls scribble/struct - (for-label scheme/base + (for-label scheme + scheme/base scheme/contract scheme/future)) @; ---------------------------------------------------------------------- -PLT's parallel-future support is only enabled if you pass -@DFlag{enable-futures} to @exec{configure} when you build PLT (and -that build currently only works with @exec{mzscheme}, not with -@exec{mred}). When parallel-future support is not enabled, -@scheme[future] just remembers the given thunk to call sequentially -on a later @scheme[touch]. +The PLT futures API enables the development of parallel programs which +take advantage of machines with multiple processors, cores, or +hardware threads. @defmodule[scheme/future]{} @defproc[(future [thunk (-> any)]) future?]{ - Starts running @scheme[thunk] in parallel. + Starts running @scheme[thunk] in parallel. The @scheme[future] + procedure returns immediately with a future descriptor value. } @defproc[(touch [f future?]) any]{ - Returns the value computed in the future @scheme[f], blocking - to let it complete if it hasn't yet completed. + Returns the value computed in the future @scheme[f], blocking until + the future completes (if it has not already completed). } @defproc[(future? [x any/c]) boolean?]{ - Returns @scheme[#t] if @scheme[x] is a future. + Returns @scheme[#t] if @scheme[x] is a future. } @defproc[(processor-count) exact-positive-integer?]{ - Returns the number of processors available on the current system. + Returns the number of processors/cores/hardware threads available on + the current system. } +@section[#:tag "besteffortpar"]{Best-Effort Parallelism} + +The @scheme[future] API represents a best-effort attempt to execute an +arbitrary segment of code in parallel. When designing programs and +algorithms which leverage @scheme[future] for parallel speedup, there +are a number of performance considerations to be aware of. + +Futures are designed to accommodate the fact that many low-level +functions provided by the MzScheme virtual machine are not reentrant. +Thus, a future will execute its work in parallel until it detects an +attempt to perform an ``unsafe'' operation (e.g. invoking a +non-reentrant function). When such an operation is detected, the +future will block until @scheme[touch]ed, upon which the remainder of +its work will be done sequentially with respect to the touching +thread (in this case, ``thread'' refers to an OS thread). + +To guarantee that unsafe operations never execute simultaneously, only +the initial OS thread used to start the MzScheme virtual machine (the +``runtime thread'') is allowed to execute them. If a parallel future +detects an attempted unsafe operation, it will signal the runtime +thread that pending unsafe work is available, then block, waiting for +the runtime thread to complete it. Note that as mentioned above, the +runtime thread will not attempt to do this work until the future is +explicitly touched. Also note that calls to @scheme[future] and +@scheme[touch] are themselves considered unsafe operations. + +Consider the following contrived example: + +@schemeblock[ + (define (add-in-parallel a b) + (let ([f (future (lambda () (+ a b)))]) + (touch f))) + + (add-in-parallel 4 8) +] + +The output of this program is, as expected: + +@verbatim|{ + 12 +}| + +Now suppose we add a print message to our function for debugging purposes: + +@schemeblock[ + (define (add-in-parallel a b) + (let ([f (future + (lambda () + (begin + (printf "Adding ~a and ~a together!~n" a b) + (+ a b))))]) + (printf "About to touch my future...~n") + (touch f))) + + (add-in-parallel 4 8) +] + +Though this program still produces the same output, no work is being +done in parallel. Because @scheme[printf] is considered an unsafe +operation, f will block, and the print invocation (along with the +subsequent add) will not be performed until the @scheme[touch] call. + +@section[#:tag "logging"]{How Do I Keep Those Cores Busy?} + +It is not always obvious when or where unsafe operations may +be causing unacceptable performance degradation in parallel programs. +A a general guideline, any primitive that is inlined will run in parallel. +For example, fixnum and flonum addition do run in parallel, +but not bignum or rational addition. Similarly, vector operations are +generally safe, but not continuation operations. Also, allocation can run +in parallel, as long as only a little bit of allocation happens. Once a significant +amount of allocation happens, a parallel thread has to rendez-vous with the +runtime thread to get new, local memory. + +To help tell what is happening in your program, the parallel threads +logs all of the points at which it has to synchronize +with the runtime thread. +For example, running the code in the previous +example in the debug log level produces the following output: + +@verbatim|{ + About to touch my future... + future: 0 waiting for runtime at 1259702453747.720947: printf + Adding 4 and 8 together! + 12 +}| + +The message indicates which future blocked, the time it blocked and +the primitive operation that caused it to block. + +To be sure we are not merely seeing the effects of a race condition in +this example, we can force the main thread to @scheme[sleep] for an +unreasonable amount of time: + +@schemeblock[ + (define (add-in-parallel a b) + (let ([f (future + (lambda () + (begin + (printf "Adding ~a and ~a together!~n" a b) + (+ a b))))]) + (sleep 10.0) + (printf "About to touch my future...~n") + (touch f))) + + (add-in-parallel 4 8) +] + +@verbatim|{ + About to touch my future... + future: 0 waiting for runtime at 1259702453747.720947: printf + Adding 4 and 8 together! + 12 +}| + +@section[#:tag "compiling"]{Enabling Futures in MzScheme Builds} + +PLT's parallel-future support is only enabled if you pass +@DFlag{enable-futures} to @exec{configure} when you build PLT (and +that build currently only works with @exec{mzscheme}, not with +@exec{mred}). When parallel-future support is not enabled, +@scheme[future] just remembers the given thunk to call sequentially on +a later @scheme[touch]. diff --git a/collects/scribblings/gui/text-class.scrbl b/collects/scribblings/gui/text-class.scrbl index c4fccef743..8e2e1cd278 100644 --- a/collects/scribblings/gui/text-class.scrbl +++ b/collects/scribblings/gui/text-class.scrbl @@ -1735,7 +1735,7 @@ If @scheme[end] is not @scheme['same] and not the same as @scheme[start], When the specified range cannot fit in the visible area, @scheme[bias] indicates which end of the range to display. When @scheme[bias] is - @scheme['same], then the start of the range is displayed. When + @scheme['start], then the start of the range is displayed. When @scheme[bias] is @scheme['end], then the end of the range is displayed. Otherwise, @scheme[bias] must be @scheme['none]. @@ -1747,7 +1747,7 @@ If the editor is scrolled, then the editor is redrawn and the return scroll-editor-to]. Scrolling is disallowed when the editor is internally locked for - reflowing (see also @|lockdiscuss|). + reflowing (see also @|lockdiscuss|). The system may scroll the editor without calling this method. For example, a canvas displaying an editor might scroll the editor to diff --git a/collects/scribblings/guide/performance.scrbl b/collects/scribblings/guide/performance.scrbl index dd78b8d3a4..0a0fc5e165 100644 --- a/collects/scribblings/guide/performance.scrbl +++ b/collects/scribblings/guide/performance.scrbl @@ -253,9 +253,9 @@ machine's instruction to add the numbers (and check for overflow). If the two numbers are not fixnums, then the next check whether whether both are flonums; in that case, the machine's floating-point operations are used directly. For functions that take any number of -arguments, such as @scheme[+], inlining is applied only for the -two-argument case (except for @scheme[-], whose one-argument case is -also inlined). +arguments, such as @scheme[+], inlining works for two or more +arguments (except for @scheme[-], whose one-argument case is also +inlined) when the arguments are either all fixnums or all flonums. Flonums are @defterm{boxed}, which means that memory is allocated to hold every result of a flonum computation. Fortunately, the diff --git a/collects/scribblings/inside/custodians.scrbl b/collects/scribblings/inside/custodians.scrbl index e2cffb78d7..b9f5a3b269 100644 --- a/collects/scribblings/inside/custodians.scrbl +++ b/collects/scribblings/inside/custodians.scrbl @@ -36,7 +36,6 @@ Creates a new custodian as a subordinate of @var{m}. If @var{m} is Places the value @var{o} into the management of the custodian @var{m}. If @var{m} is @cpp{NULL}, the current custodian is used. - The @var{f} function is called by the custodian if it is ever asked to ``shutdown'' its values; @var{o} and @var{data} are passed on to @var{f}, which has the type @@ -52,6 +51,10 @@ be remembered until either the custodian shuts it down or zero, the value is allowed to be garbaged collected (and automatically removed from the custodian). +Independent of whether @var{strong} is zero, the value @var{o} is +initially weakly held. A value associated with a custodian can +therefore be finalized via will executors. + The return value from @cpp{scheme_add_managed} can be used to refer to the value's custodian later in a call to @cpp{scheme_remove_managed}. A value can be registered with at diff --git a/collects/scribblings/inside/hooks.scrbl b/collects/scribblings/inside/hooks.scrbl index 52b38198d4..f792483917 100644 --- a/collects/scribblings/inside/hooks.scrbl +++ b/collects/scribblings/inside/hooks.scrbl @@ -57,6 +57,13 @@ Sets the path to be returned by @scheme[(find-system-path 'collects-dir)].} +@function[(void scheme_set_addon_path + [Scheme_Object* path])]{ + +Sets the path to be returned by @scheme[(find-system-path +'addon-dir)].} + + @function[(void scheme_init_collection_paths_post [Scheme_Env* env] [Scheme_Object* pre_extra_paths] diff --git a/collects/scribblings/main/private/search.js b/collects/scribblings/main/private/search.js index e0aeda00aa..632e0b24ee 100644 --- a/collects/scribblings/main/private/search.js +++ b/collects/scribblings/main/private/search.js @@ -226,7 +226,7 @@ function InitializeSearch() { result_links.push(n); AdjustResultsNum(); // get search string - var init_q = GetArgFromURL(location,"q"); + var init_q = GetPageArg("q",false); if (init_q && init_q != "") query.value = init_q; ContextFilter(); DoSearch(); @@ -599,7 +599,7 @@ function UpdateResults() { if (first_search_result < 0 || first_search_result >= search_results.length) first_search_result = 0; - var link_lang = (cur_plt_lang && ("?lang="+escape(cur_plt_lang))); + var link_args = (page_query_string && ("?"+page_query_string)); for (var i=0; i'; var href = UncompactUrl(res[1]); - if (link_lang) { + if (link_args) { var hash = href.indexOf("#"); if (hash >= 0) - href = href.substring(0,hash) + link_lang + href.substring(hash); + href = href.substring(0,hash) + link_args + href.substring(hash); else - href = href + link_lang; + href = href + link_args; } result_links[i].innerHTML = '' diff --git a/collects/scribblings/reference/collects.scrbl b/collects/scribblings/reference/collects.scrbl index ace19f3652..4b6c9b0880 100644 --- a/collects/scribblings/reference/collects.scrbl +++ b/collects/scribblings/reference/collects.scrbl @@ -33,11 +33,26 @@ scheme .... ] -In general, the @scheme[_rel-string] in @scheme[(lib _rel-string)] -consists of one or more path elements that name collections, and then -a final path element that names a library file; the path elements are -separated by @litchar{/}. If the final element has no file suffix, -then @litchar{/main.ss} is implicitly appended to the path. +This example is more compactly and more commonly written as + +@schememod[ +scheme +(require setup/getinfo + games/cards/cards) +.... +] + +When an identifier @scheme[_id] is used in a @scheme[require] form, it +is converted to @scheme[(lib _rel-string)] where @scheme[_rel-string] +is the string form of @scheme[_id]. + +A @scheme[_rel-string] in @scheme[(lib _rel-string)] consists of one +or more path elements that name collections, and then a final path +element that names a library file; the path elements are separated by +@litchar{/}. If @scheme[_rel-string] contains no @litchar{/}s, then +then @litchar{/main.ss} is implicitly appended to the path. If +@scheme[_rel-string] contains @litchar{/} but does not end with a file +suffix, then @litchar{.ss} is implicitly appended to the path. The translation of a @scheme[planet] or @scheme[lib] path to a @scheme[module] declaration is determined by the @tech{module name diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index 2114c3b961..6e9a8aa3fd 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -1196,8 +1196,8 @@ This property should only be present if the contract is a flat contract. In the @mz-examples[#:eval (contract-eval) (flat-pred? (-> integer? integer?)) - (let ([c (between/c 1 10)] - [pred ((flat-get c) c)]) + (let* ([c (between/c 1 10)] + [pred ((flat-get c) c)]) (list (pred 9) (pred 11)))] } diff --git a/collects/scribblings/reference/exns.scrbl b/collects/scribblings/reference/exns.scrbl index 2117c1d273..9fc843868b 100644 --- a/collects/scribblings/reference/exns.scrbl +++ b/collects/scribblings/reference/exns.scrbl @@ -40,8 +40,20 @@ multiple returns/escapes are impossible. All exceptions raised by Breaks are disabled from the time the exception is raised until the exception handler obtains control, and the handler itself is @scheme[parameterize-break]ed to disable breaks initially; see -@secref["breakhandler"] for more information on breaks.} +@secref["breakhandler"] for more information on breaks. +@examples[ +(with-handlers ([number? (lambda (n) + (+ n 5))]) + (raise 18 #t)) +(define-struct (my-exception exn:fail:user) ()) +(with-handlers ([my-exception? (lambda (e) + #f)]) + (+ 5 (raise (make-my-exception + "failed" + (current-continuation-marks))))) +(raise 'failed #t) +]} @defproc*[([(error [sym symbol?]) any] [(error [msg string?][v any/c] ...) any] @@ -72,7 +84,13 @@ ways: ] In all cases, the constructed message string is passed to -@scheme[make-exn:fail], and the resulting exception is raised.} +@scheme[make-exn:fail], and the resulting exception is raised. + +@examples[ +(error 'failed) +(error "failed" 23 'pizza (list 1 2 3)) +(error 'failed "~a failed because ~a" 'method-a "no argument supplied") +]} @defproc*[([(raise-user-error [sym symbol?]) any] [(raise-user-error [msg string?][v any/c] ...) any] @@ -83,7 +101,13 @@ Like @scheme[error], but constructs an exception with default @tech{error display handler} does not show a ``stack trace'' for @scheme[exn:fail:user] exceptions (see @secref["contmarks"]), so @scheme[raise-user-error] should be used for errors that are intended -for end users.} +for end users. + +@examples[ +(raise-user-error 'failed) +(raise-user-error "failed" 23 'pizza (list 1 2 3)) +(raise-user-error 'failed "~a failed because ~a" 'method-a "no argument supplied") +]} @defproc*[([(raise-type-error [name symbol?][expected string?][v any/c]) any] @@ -102,7 +126,20 @@ In the second form, the bad argument is indicated by an index arguments @scheme[v] are provided (in order). The resulting error message names the bad argument and also lists the other arguments. If @scheme[bad-pos] is not less than the number of @scheme[v]s, the -@exnraise[exn:fail:contract].} +@exnraise[exn:fail:contract]. + +@examples[ +(define (feed-cow animal) + (if (not (eq? animal 'cow)) + (raise-type-error 'feed-cow "cow" animal) + "fed the cow")) +(feed-cow 'turkey) +(define (feed-animals cow sheep goose cat) + (if (not (eq? goose 'goose)) + (raise-type-error 'feed-animals "goose" 2 cow sheep goose cat) + "fed the animals")) +(feed-animals 'cow 'sheep 'dog 'cat) +]} @defproc[(raise-mismatch-error [name symbol?][message string?][v any/c]) any]{ diff --git a/collects/scribblings/reference/filesystem.scrbl b/collects/scribblings/reference/filesystem.scrbl index 240ece9b6d..edc90374b2 100644 --- a/collects/scribblings/reference/filesystem.scrbl +++ b/collects/scribblings/reference/filesystem.scrbl @@ -80,10 +80,15 @@ by @scheme[kind], which must be one of the following: ]} - @item{@indexed-scheme['addon-dir] --- a directory for installing PLT Scheme - extensions. It's the same as @scheme['pref-dir], except under Mac OS - X, where it is @filepath{Library/PLT Scheme} in the user's home - directory. This directory might not exist.} + @item{@indexed-scheme['addon-dir] --- a directory for installing PLT + Scheme extensions. This directory is specified by the + @indexed-envvar{PLTADDONDIR} environment variable, and it can be + overridden by the @DFlag{addon} or @Flag{A} command-line flag. If no + environment variable or flag is specified, or if the value is not a + legal path name, then this directory defaults to + @filepath{Library/PLT Scheme} in the user's home directory under Mac + OS X and @scheme['pref-dir] otherwise. This directory might not + exist.} @item{@indexed-scheme['doc-dir] --- the standard directory for storing the current user's documents. Under Unix, it's the same as @@ -593,17 +598,6 @@ Reads all characters from @scheme[path] and returns them as a @tech{byte string}. The @scheme[mode-flag] argument is the same as for @scheme[open-input-file].} -@defproc[(file->lines [path path-string?] - [#:mode mode-flag (or/c 'binary 'text) 'binary] - [#:line-mode line-mode (or/c 'linefeed 'return 'return-linefeed 'any 'any-one) 'any]) - bytes?]{ - -Read all characters from @scheme[path], breaking them into lines. The -@scheme[line-mode] argument is the same as the second argument to -@scheme[read-line], but the default is @scheme['any] instead of -@scheme['linefeed]. The @scheme[mode-flag] argument is the same as for -@scheme[open-input-file].} - @defproc[(file->value [path path-string?] [#:mode mode-flag (or/c 'binary 'text) 'binary]) bytes?]{ @@ -612,10 +606,29 @@ Reads a single S-expression from @scheme[path] using @scheme[read]. The @scheme[mode-flag] argument is the same as for @scheme[open-input-file].} +@defproc[(file->list [path path-string?] + [proc (input-port? . -> . any/c) read] + [#:mode mode-flag (or/c 'binary 'text) 'binary]) + (listof any/c)]{ +Repeatedly calls @scheme[proc] to consume the contents of +@scheme[path], until @scheme[eof] is produced. The @scheme[mode-flag] +argument is the same as for @scheme[open-input-file]. } + +@defproc[(file->lines [path path-string?] + [#:mode mode-flag (or/c 'binary 'text) 'binary] + [#:line-mode line-mode (or/c 'linefeed 'return 'return-linefeed 'any 'any-one) 'any]) + (listof string?)]{ + +Read all characters from @scheme[path], breaking them into lines. The +@scheme[line-mode] argument is the same as the second argument to +@scheme[read-line], but the default is @scheme['any] instead of +@scheme['linefeed]. The @scheme[mode-flag] argument is the same as for +@scheme[open-input-file].} + @defproc[(file->bytes-lines [path path-string?] [#:mode mode-flag (or/c 'binary 'text) 'binary] [#:line-mode line-mode (or/c 'linefeed 'return 'return-linefeed 'any 'any-one) 'any]) - bytes?]{ + (listof bytes?)]{ Like @scheme[file->lines], but reading bytes and collecting them into lines like @scheme[read-bytes-line].} diff --git a/collects/scribblings/reference/mz.ss b/collects/scribblings/reference/mz.ss index 5381a13a70..d9b3976907 100644 --- a/collects/scribblings/reference/mz.ss +++ b/collects/scribblings/reference/mz.ss @@ -128,6 +128,6 @@ (define-syntax speed (syntax-rules () [(_ id what) - (t "An" (scheme id) "application can provide better performance for" + (t "An " (scheme id) " application can provide better performance for " (elem what) - "iteration when it appears directly in a" (scheme for) "clause.")]))) + " iteration when it appears directly in a " (scheme for) " clause.")]))) diff --git a/collects/scribblings/reference/numbers.scrbl b/collects/scribblings/reference/numbers.scrbl index 59acdabaac..9426b51eb1 100644 --- a/collects/scribblings/reference/numbers.scrbl +++ b/collects/scribblings/reference/numbers.scrbl @@ -849,6 +849,58 @@ Returns @scheme[#t] if the native encoding of numbers is big-endian for the machine running Scheme, @scheme[#f] if the native encoding is little-endian.} +@; ------------------------------------------------------------------------ +@section{Inexact-Real Vectors} + +A @deftech{flvector} is like a @tech{vector}, but it holds only +inexact real numbers. This representation can be more compact, and +unsafe operations on @tech{flvector}s (see +@schememodname[scheme/unsafe/ops]) can execute more efficiently than +unsafe operations on @tech{vectors} of inexact reals. + +An f64vector as provided by @schememodname[scheme/foreign] stores the +same kinds of values as an @tech{flvector}, but with extra +indirections that make f64vectors more convenient for working with +foreign libraries. The lack of indirections make unsafe +@tech{flvector} access more efficient. + +@defproc[(flvector? [v any/c]) boolean?]{ + +Returns @scheme[#t] if @scheme[v] is a @tech{flvector}, @scheme[#f] otherwise.} + +@defproc[(flvector [x inexact-real?] ...) flvector?]{ + +Creates a @tech{flvector} containing the given inexact real numbers.} + +@defproc[(make-flvector [size exact-nonnegative-integer?] + [x inexact-real? 0.0]) + flvector?]{ + +Creates a @tech{flvector} with @scheme[size] elements, where every +slot in the @tech{flvector} is filled with @scheme[x].} + +@defproc[(flvector-length [vec flvector?]) exact-nonnegative-integer?]{ + +Returns the length of @scheme[vec] (i.e., the number of slots in the +@tech{flvector}).} + + +@defproc[(flvector-ref [vec flvector?] [pos exact-nonnegative-integer?]) + inexact-real?]{ + +Returns the inexact real number in slot @scheme[pos] of +@scheme[vec]. The first slot is position @scheme[0], and the last slot +is one less than @scheme[(flvector-length vec)].} + +@defproc[(flvector-set! [vec flvector?] [pos exact-nonnegative-integer?] + [x inexact-real?]) + inexact-real?]{ + +Sets the inexact real number in slot @scheme[pos] of @scheme[vec]. The +first slot is position @scheme[0], and the last slot is one less than +@scheme[(flvector-length vec)].} + + @; ------------------------------------------------------------------------ @section{Extra Constants and Functions} @@ -901,13 +953,15 @@ Returns the hyperbolic tangent of @scheme[z].} Computes the greatest exact integer @scheme[m] such that: @schemeblock[(<= (expt 10 m) (inexact->exact r))] -Hence also +Hence also: @schemeblock[(< (inexact->exact r) - (expt 10 (add1 m)))]. + (expt 10 (add1 m)))] @mz-examples[#:eval math-eval (order-of-magnitude 999) - (order-of-magnitude 1000)] + (order-of-magnitude 1000) + (order-of-magnitude 1/100) + (order-of-magnitude 1/101)] } @; ---------------------------------------------------------------------- diff --git a/collects/scribblings/reference/pairs.scrbl b/collects/scribblings/reference/pairs.scrbl index aea5846ffb..f562cf4de8 100644 --- a/collects/scribblings/reference/pairs.scrbl +++ b/collects/scribblings/reference/pairs.scrbl @@ -878,12 +878,12 @@ without building the intermediate list. ]} @defproc[(count [proc procedure?] [lst list?] ...+) - list?]{ + exact-nonnegative-integer?]{ -Returns @scheme[(length (filter proc lst ...))], but -without building the intermediate list. +Returns @scheme[(length (filter proc lst ...))], but without building +the intermediate list. -@mz-examples[ +@mz-examples[#:eval list-eval (count positive? '(1 -1 2 3 -2 5)) ]} diff --git a/collects/scribblings/reference/procedures.scrbl b/collects/scribblings/reference/procedures.scrbl index 1332e6707e..bc33071700 100644 --- a/collects/scribblings/reference/procedures.scrbl +++ b/collects/scribblings/reference/procedures.scrbl @@ -53,8 +53,18 @@ result is @scheme[values]. Returns a procedure that is like @scheme[proc], except that its name as returned by @scheme[object-name] (and as printed for debugging) is -@scheme[name].} +@scheme[name]. +The given @scheme[name] is used for printing an error message if the +resulting procedure is applied to the wrong number of arguments. In +addition, if @scheme[proc] is an @tech{accessor} or @tech{mutator} +produced by @scheme[define-struct], +@scheme[make-struct-field-accessor], or +@scheme[make-struct-field-mutator], the resulting procedure also uses +@scheme[name] when its (first) argument has the wrong type. More +typically, however, @scheme[name] is not used for reporting errors, +since the procedure name is typically hard-wired into an internal +check.} @; ---------------------------------------- @section{Keywords and Arity} @@ -243,7 +253,7 @@ See also @scheme[procedure-arity?].} @defthing[prop:procedure struct-type-property?]{ -A @tech{structure type property} to indentify structure types whose +A @tech{structure type property} to identify structure types whose instances can be applied as procedures. In particular, when @scheme[procedure?] is applied to the instance, the result will be @scheme[#t], and when an instance is used in the function position of @@ -441,8 +451,8 @@ primitive closure rather than a simple primitive procedure, Returns the arity of the result of the primitive procedure @scheme[prim] (as opposed to the procedure's input arity as returned -by @scheme[arity]). For most primitives, this procedure returns -@scheme[1], since most primitives return a single value when +by @scheme[procedure-arity]). For most primitives, this procedure +returns @scheme[1], since most primitives return a single value when applied.} @; ---------------------------------------- diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl index 37c3056b97..9af0edf601 100644 --- a/collects/scribblings/reference/stx-trans.scrbl +++ b/collects/scribblings/reference/stx-trans.scrbl @@ -63,7 +63,7 @@ is identified by the @scheme[prop:set!-transformer] property of @defthing[prop:set!-transformer struct-type-property?]{ -A @tech{structure type property} to indentify structure types that act +A @tech{structure type property} to identify structure types that act as @tech{assignment transformers} like the ones created by @scheme[make-set!-transformer]. @@ -133,7 +133,7 @@ create @scheme[transformer] or as indicated by a @defthing[prop:rename-transformer struct-type-property?]{ -A @tech{structure type property} to indentify structure types that act +A @tech{structure type property} to identify structure types that act as @tech{rename transformers} like the ones created by @scheme[make-rename-transformer]. @@ -576,8 +576,9 @@ exports of the module. Returns @scheme[id-stx] if no binding in the current expansion context shadows @scheme[id-stx] (ignoring unsealed @tech{internal-definition -contexts}), if @scheme[id-stx] has no module bindings in its lexical -information, and if the current expansion context is not a +contexts} and identifiers that had the @indexed-scheme['unshadowable] +@tech{syntax property}), if @scheme[id-stx] has no module bindings in +its lexical information, and if the current expansion context is not a @tech{module context}. If a binding of @scheme[inner-identifier] shadows @scheme[id-stx], the diff --git a/collects/scribblings/reference/unsafe.scrbl b/collects/scribblings/reference/unsafe.scrbl index f01ba82236..acee583bf8 100644 --- a/collects/scribblings/reference/unsafe.scrbl +++ b/collects/scribblings/reference/unsafe.scrbl @@ -1,6 +1,10 @@ #lang scribble/doc @(require "mz.ss" - (for-label scheme/unsafe/ops)) + (for-label scheme/unsafe/ops + (only-in scheme/foreign + f64vector? + f64vector-ref + f64vector-set!))) @title[#:tag "unsafe"]{Unsafe Operations} @@ -165,6 +169,27 @@ Unsafe versions of @scheme[bytes-length], @scheme[bytes-ref], and fixnum).} +@deftogether[( +@defproc[(unsafe-flvector-length [v flvector?]) fixnum?] +@defproc[(unsafe-flvector-ref [v flvector?][k fixnum?]) any/c] +@defproc[(unsafe-flvector-set! [v flvector?][k fixnum?][x inexact-real?]) void?] +)]{ + +Unsafe versions of @scheme[flvector-length], @scheme[flvector-ref], and +@scheme[flvector-set!]. A @tech{flvector}'s size can never be larger than a +@tech{fixnum} (so even @scheme[flvector-length] always returns a +fixnum).} + + +@deftogether[( +@defproc[(unsafe-f64vector-ref [vec f64vector?][k fixnum?]) inexact-real?] +@defproc[(unsafe-f64vector-set! [vec f64vector?][k fixnum?][n inexact-real?]) void?] +)]{ + +Unsafe versions of @scheme[f64vector-ref] and +@scheme[f64vector-set!].} + + @deftogether[( @defproc[(unsafe-struct-ref [v any/c][k fixnum?]) any/c] @defproc[(unsafe-struct-set! [v any/c][k fixnum?][val any/c]) void?] diff --git a/collects/scribblings/reference/vectors.scrbl b/collects/scribblings/reference/vectors.scrbl index b13d48a30c..fd90298fb3 100644 --- a/collects/scribblings/reference/vectors.scrbl +++ b/collects/scribblings/reference/vectors.scrbl @@ -184,7 +184,7 @@ Applies @scheme[proc] to the elements of the @scheme[vec]s from the v ]} -@defproc[(vector-append [lst list?] ...) list?]{ +@defproc[(vector-append [vec vector?] ...) vector?]{ Creates a fresh vector that contains all of the elements of the given vectors in order. @@ -194,19 +194,19 @@ of the elements of the given vectors in order. } -@defproc[(vector-take [vec vector?] [pos exact-nonnegative-integer?]) list?]{ +@defproc[(vector-take [vec vector?] [pos exact-nonnegative-integer?]) vector?]{ Returns a fresh vector whose elements are the first @scheme[pos] elements of @scheme[vec]. If @scheme[vec] has fewer than -@scheme[pos] elements, the @exnraise[exn:fail:contract]. +@scheme[pos] elements, then the @exnraise[exn:fail:contract]. @mz-examples[#:eval vec-eval (vector-take #(1 2 3 4) 2) ]} -@defproc[(vector-take-right [vec vector?] [pos exact-nonnegative-integer?]) list?]{ +@defproc[(vector-take-right [vec vector?] [pos exact-nonnegative-integer?]) vector?]{ Returns a fresh vector whose elements are the last @scheme[pos] elements of @scheme[vec]. If @scheme[vec] has fewer than -@scheme[pos] elements, the @exnraise[exn:fail:contract]. +@scheme[pos] elements, then the @exnraise[exn:fail:contract]. @mz-examples[#:eval vec-eval (vector-take-right #(1 2 3 4) 2) @@ -215,7 +215,7 @@ Returns a fresh vector whose elements are the last @scheme[pos] elements of @defproc[(vector-drop [vec vector?] [pos exact-nonnegative-integer?]) vector?]{ Returns a fresh vector whose elements are the elements of @scheme[vec] after the first @scheme[pos] elements. If @scheme[vec] has fewer - than @scheme[pos] elements, the @exnraise[exn:fail:contract]. + than @scheme[pos] elements, then the @exnraise[exn:fail:contract]. @mz-examples[#:eval vec-eval (vector-drop #(1 2 3 4) 2) @@ -224,7 +224,7 @@ Returns a fresh vector whose elements are the elements of @scheme[vec] @defproc[(vector-drop-right [vec vector?] [pos exact-nonnegative-integer?]) vector?]{ Returns a fresh vector whose elements are the elements of @scheme[vec] before the first @scheme[pos] elements. If @scheme[vec] has fewer - than @scheme[pos] elements, the @exnraise[exn:fail:contract]. + than @scheme[pos] elements, then the @exnraise[exn:fail:contract]. @mz-examples[#:eval vec-eval (vector-drop-right #(1 2 3 4) 2) @@ -288,11 +288,11 @@ returns @scheme[#f]. ]} -@defproc[(vector-count [proc procedure?] [lst list?] ...+) - list?]{ +@defproc[(vector-count [proc procedure?] [vec vector?] ...+) + exact-nonnegative-integer?]{ -Returns @scheme[(vector-length (vector-filter proc lst ...))], but -without building the intermediate list. +Returns the number of elements of the @scheme[vec ...] (taken in +parallel) on which @scheme[proc] does not evaluate to @scheme[#f]. @mz-examples[#:eval vec-eval (vector-count even? #(1 2 3 4 5)) diff --git a/collects/scribblings/tools/unit.scrbl b/collects/scribblings/tools/unit.scrbl index 10a6699d3d..2f98278140 100644 --- a/collects/scribblings/tools/unit.scrbl +++ b/collects/scribblings/tools/unit.scrbl @@ -574,6 +574,11 @@ Shows the interactions window Returns the currently active tab. } + +@defmethod[(open-in-new-tab [filename (or/c path-string? #f)]) void?]{ + Opens a new tab in this frame. If @scheme[filename] is a @scheme[path-string?], + It loads that file in the definitions window of the new tab. +} @defmethod[#:mode public-final (close-current-tab) void?]{ Closes the current tab, making some other tab visible. diff --git a/collects/srfi/19/time.ss b/collects/srfi/19/time.ss index 73d647c099..56dcc0a9f7 100644 --- a/collects/srfi/19/time.ss +++ b/collects/srfi/19/time.ss @@ -390,13 +390,13 @@ (define (time>=? time1 time2) (tm:time-compare-check time1 time2 'time>=?) - (or (>= (time-second time1) (time-second time2)) + (or (> (time-second time1) (time-second time2)) (and (= (time-second time1) (time-second time2)) (>= (time-nanosecond time1) (time-nanosecond time2))))) (define (time<=? time1 time2) (tm:time-compare-check time1 time2 'time<=?) - (or (<= (time-second time1) (time-second time2)) + (or (< (time-second time1) (time-second time2)) (and (= (time-second time1) (time-second time2)) (<= (time-nanosecond time1) (time-nanosecond time2))))) diff --git a/collects/syntax/module-reader.ss b/collects/syntax/module-reader.ss index ad3f13e394..555d574068 100644 --- a/collects/syntax/module-reader.ss +++ b/collects/syntax/module-reader.ss @@ -21,41 +21,42 @@ (if (not (and (pair? body) (pair? (cdr body)) (keyword? (syntax-e (car body))))) - (datum->syntax stx body stx) - (let* ([k (car body)] [k* (syntax-e k)] [v (cadr body)]) - (case k* - [(kwd) (if var - (err (format "got two ~s keywords" k*) k) - (begin (set! var v) (loop (cddr body))))] - ... - [else (err "got an unknown keyword" (car body))]))))) + (datum->syntax stx body stx) + (let* ([k (car body)] [k* (syntax-e k)] [v (cadr body)]) + (case k* + [(kwd) (if var + (err (format "got two ~s keywords" k*) k) + (begin (set! var v) (loop (cddr body))))] + ... + [else (err "got an unknown keyword" (car body))]))))) checks ... (unless var (set! var default)) ...)) (define (datum->syntax stx 'language-module stx)) (define (datum->syntax stx 'language-data stx)) (define (construct-reader lang body) (keywords body - [#:language ~lang lang] - [#:read ~read #'read] - [#:read-syntax ~read-syntax #'read-syntax] - [#:wrapper1 ~wrapper1 #'#f] - [#:wrapper2 ~wrapper2 #'#f] - [#:whole-body-readers? ~whole-body-readers? #'#f] - [#:info ~info #'#f] - [(when (equal? (and lang #t) (and ~lang #t)) - (err (string-append - "must specify either a module language, or #:language" - (if (and lang ~lang) ", not both" "")))) - (unless (equal? (and ~read #t) (and ~read-syntax #t)) - (err "must specify either both #:read and #:read-syntax, or none")) - (when (and ~whole-body-readers? (not (and ~read ~read-syntax))) - (err "got a #:whole-body-readers? without #:read and #:read-syntax"))]) - ;; FIXME: a lot of the generated code is constant and should be lifted - ;; out of the template: + [#:language ~lang lang] + [#:read ~read #'read] + [#:read-syntax ~read-syntax #'read-syntax] + [#:wrapper1 ~wrapper1 #'#f] + [#:wrapper2 ~wrapper2 #'#f] + [#:whole-body-readers? ~whole-body-readers? #'#f] + [#:info ~info #'#f] + [(when (equal? (and lang #t) (and ~lang #t)) + (err (string-append + "must specify either a module language, or #:language" + (if (and lang ~lang) ", not both" "")))) + (unless (equal? (and ~read #t) (and ~read-syntax #t)) + (err "must specify either both #:read and #:read-syntax, or none")) + (when (and ~whole-body-readers? (not (and ~read ~read-syntax))) + (err "got a #:whole-body-readers? without #:read and #:read-syntax"))]) + ;; FIXME: some generated code is constant and should be lifted out of the + ;; template: (quasisyntax/loc stx (#%module-begin #,@body - (#%provide (rename lang:read read) (rename lang:read-syntax read-syntax) + (#%provide (rename lang:read read) + (rename lang:read-syntax read-syntax) read-properties get-info-getter get-info) (define (lang:read in modpath line col pos) (wrap-internal/wrapper #f #f in modpath line col pos)) @@ -66,49 +67,27 @@ [lang (car props)] [#, lang] ;\ visible in [data (cadr props)] [#, data] ;/ user-code [read (if stx? - (let ([rd #,~read-syntax]) (lambda (in) (rd src in))) - #,~read)] + (let ([rd #,~read-syntax]) + (lambda (in) (rd src in))) + #,~read)] [w1 #,~wrapper1] [w2 #,~wrapper2] [whole? #,~whole-body-readers?] - [rd (lambda (in) (wrap-internal (if (and (not stx?) (syntax? lang)) - (syntax->datum lang) - lang) - in read whole? w1 stx? - modpath src line col pos))] + [rd (lambda (in) + (wrap-internal (if (and (not stx?) (syntax? lang)) + (syntax->datum lang) + lang) + in read whole? w1 stx? + modpath src line col pos))] [r (cond [(not w2) (rd in)] [(ar? w2 3) (w2 in rd stx?)] [else (w2 in rd)])]) (if stx? - (syntax-property r 'module-language - (vector (syntax->datum modpath) 'get-info-getter - props)) - r))) - (define lang* - (let ([lang #,~lang]) - (if (not (procedure? lang)) - (list lang #f) - (cond [(ar? lang 5) lang] - [(ar? lang 1) (lambda (in . _) (lang in))] - [(ar? lang 0) (lambda _ (lang))] - [else (raise-type-error - 'syntax/module-reader - "language+reader procedure of 5, 1, or 0 arguments" - lang)])))) - (define (read-properties in modpath line col pos) - (if (not (procedure? lang*)) - lang* - (call-with-values - (lambda () (parameterize ([current-input-port in]) - (lang* in modpath line col pos))) - (lambda xs - (case (length xs) - [(2) xs] [(1) (list (car xs) #f)] - [else (error 'syntax/module-reader - "wrong number of results from ~a, ~a ~e" - "the #:language function" - "expected 1 or 2 values, got" - (length xs))]))))) + (syntax-property r + 'module-language + (vector (syntax->datum modpath) 'get-info-getter props)) + r))) + (define read-properties (lang->read-properties #,~lang)) (define (get-info in modpath line col pos) (get-info-getter (read-properties in modpath line col pos))) (define (get-info-getter props) @@ -124,14 +103,14 @@ [#, data] ;/ user-code [info #,~info]) (if (or (not info) (and (procedure? info) (ar? info 3))) - info - (raise-type-error 'syntax/module-reader - "info procedure of 3 arguments" info)))) + info + (raise-type-error 'syntax/module-reader + "info procedure of 3 arguments" info)))) (define (language-info what defval) (if info - (let ([r (info what defval default-info)]) - (if (eq? r default-info) (default-info what defval) r)) - (default-info what defval))) + (let ([r (info what defval default-info)]) + (if (eq? r default-info) (default-info what defval) r)) + (default-info what defval))) language-info)))) (syntax-case stx () [(_ lang body ...) @@ -139,55 +118,104 @@ (construct-reader #''lang (syntax->list #'(body ...)))] [(_ body ...) (construct-reader #f (syntax->list #'(body ...)))])) + ;; turns the language specification (either a language or some flavor of a + ;; function that returns a language and some properties) into a function that + ;; returns (list ) + (define (lang->read-properties lang) + (define lang* + (cond [(not (procedure? lang)) (list lang #f)] + [(ar? lang 5) lang] + [(ar? lang 1) (lambda (in . _) (lang in))] + [(ar? lang 0) (lambda _ (lang))] + [else (raise-type-error + 'syntax/module-reader + "language+reader procedure of 5, 1, or 0 arguments" + lang)])) + (define (read-properties in modpath line col pos) + (if (not (procedure? lang*)) + lang* + (parameterize ([current-input-port in]) + (call-with-values + (lambda () (lang* in modpath line col pos)) + (lambda xs + (case (length xs) + [(2) xs] [(1) (list (car xs) #f)] + [else (error 'syntax/module-reader + "wrong number of results from ~a, ~a ~e" + "the #:language function" + "expected 1 or 2 values, got" + (length xs))])))))) + read-properties) + + ;; Since there are users that wrap with `#%module-begin' in their reader + ;; or wrapper1 functions, we need to avoid double-wrapping. Having to do + ;; this for #lang readers should be considered deprecated, and hopefully + ;; one day we'll move to just doing it unilaterally (making this code throw + ;; an error in that case before that's done). + ;; This function takes "body" as a sequence of expressions (can be syntaxes + ;; and/or sexprs) and returns a new body as a *single* expression that is + ;; wrapped in a `#%module-begin' -- using the input if it was a single + ;; pre-wrapped expression. + (define (wrap-module-begin body) + (let ([exprs (if (syntax? body) (syntax->list body) body)]) + (if (and (pair? exprs) (null? (cdr exprs)) + (let* ([x (car exprs)] + [x (if (syntax? x) (syntax-e x) x)] + [x (and (pair? x) (car x))] + [x (if (syntax? x) (syntax-e x) x)]) + (eq? x '#%module-begin))) + (car exprs) + (cons '#%module-begin body)))) + (define (wrap-internal lang port read whole? wrapper stx? modpath src line col pos) (let* ([lang (if stx? (datum->syntax #f lang modpath modpath) lang)] [body (lambda () (if whole? - (read port) - (let loop ([a null]) - (let ([v (read port)]) - (if (eof-object? v) (reverse a) (loop (cons v a)))))))] + (read port) + (let loop ([a null]) + (let ([v (read port)]) + (if (eof-object? v) + (reverse a) + (loop (cons v a)))))))] [body (cond [(not wrapper) (body)] [(ar? wrapper 2) (wrapper body stx?)] [else (wrapper body)])] + [body (wrap-module-begin body)] [all-loc (vector src line col pos (let-values ([(l c p) (port-next-location port)]) (and p (- p pos))))] - [body (if (and stx? (not (syntax? body))) - (datum->syntax #f body all-loc) - body)] [p-name (object-name port)] [name (if (path? p-name) - (let-values ([(base name dir?) (split-path p-name)]) - (string->symbol - (path->string (path-replace-suffix name #"")))) - 'page)] + (let-values ([(base name dir?) (split-path p-name)]) + (string->symbol + (path->string (path-replace-suffix name #"")))) + 'anonymous-module)] [tag-src (lambda (v) (if stx? - (datum->syntax - #f v (vector src line col pos - (- (or (syntax-position modpath) (add1 pos)) - pos))) - v))] - [r `(,(tag-src 'module) ,(tag-src name) ,lang . ,body)]) + (datum->syntax + #f v (vector src line col pos + (- (or (syntax-position modpath) + (add1 pos)) + pos))) + v))] + [r `(,(tag-src 'module) ,(tag-src name) ,lang ,body)]) (if stx? (datum->syntax #f r all-loc) r))) (define (wrap lang port read modpath src line col pos) (wrap-internal lang port read #f #f #f modpath src line col pos)) - (define (make-meta-reader self-sym module-path-desc spec->module-path - convert-read - convert-read-syntax - convert-get-info - #:read-spec [read-spec - (lambda (in) - (let ([spec (regexp-try-match #px"^[ \t]+(.*?)(?=\\s|$)" in)]) - (and spec - (let ([s (cadr spec)]) - (if (equal? s "") - #f - s)))))]) + (define (make-meta-reader + self-sym module-path-desc spec->module-path + convert-read + convert-read-syntax + convert-get-info + #:read-spec + [read-spec + (lambda (in) + (let ([spec (regexp-try-match #px"^[ \t]+(.*?)(?=\\s|$)" in)]) + (and spec (let ([s (cadr spec)]) + (if (equal? s "") #f s)))))]) (define (get in export-sym src line col pos mk-fail-thunk) (define (bad str eof?) ((if eof? raise-read-eof-error raise-read-error) @@ -198,35 +226,41 @@ (and pos pos2 (- pos2 pos))))) (define spec (read-spec in)) (if (not spec) - (bad #f (eof-object? (peek-byte in))) - (let ([parsed-spec (spec->module-path spec)]) - (if parsed-spec - (begin ((current-reader-guard) parsed-spec) - (dynamic-require parsed-spec export-sym (mk-fail-thunk spec))) - (bad spec #f))))) + (bad #f (eof-object? (peek-byte in))) + (let ([parsed-spec (spec->module-path spec)]) + (if parsed-spec + (begin ((current-reader-guard) parsed-spec) + (dynamic-require parsed-spec export-sym + (mk-fail-thunk spec))) + (bad spec #f))))) (define (-get-info inp mod line col pos) (let ([r (get inp 'get-info (object-name inp) line col pos - (lambda (spec) (lambda () (lambda (inp mod line col pos) - (lambda (tag defval) defval)))))]) + (lambda (spec) + (lambda () + (lambda (inp mod line col pos) + (lambda (tag defval) defval)))))]) (convert-get-info (r inp mod line col pos)))) (define (read-fn in read-sym args src mod line col pos convert) (let ([r (get in read-sym src #|mod|# line col pos (lambda (spec) (lambda () - (error self-sym "cannot find reader for `#lang ~a ~a'" + (error read-sym "cannot find reader for `#lang ~a ~a'" self-sym spec))))]) (let ([r (convert r)]) - (if (and (procedure? r) (procedure-arity-includes? r (+ 5 (length args)))) - (apply r (append args (list in mod line col pos))) - (apply r (append args (list in))))))) - + (if (and (procedure? r) + (procedure-arity-includes? r (+ 5 (length args)))) + (apply r (append args (list in mod line col pos))) + (apply r (append args (list in))))))) + (define (-read inp mod line col pos) - (read-fn inp 'read null (object-name inp) mod line col pos convert-read)) - + (read-fn inp 'read null (object-name inp) mod line col pos + convert-read)) + (define (-read-syntax src inp mod line col pos) - (read-fn inp 'read-syntax (list src) src mod line col pos convert-read-syntax)) + (read-fn inp 'read-syntax (list src) src mod line col pos + convert-read-syntax)) (values -read -read-syntax -get-info))) diff --git a/collects/syntax/private/id-table.ss b/collects/syntax/private/id-table.ss index 8241924e91..58a5426ee1 100644 --- a/collects/syntax/private/id-table.ss +++ b/collects/syntax/private/id-table.ss @@ -4,6 +4,7 @@ scheme/dict) (provide id-table-position?) +#| (require (rename-in scheme/base [car s:car])) (define-syntax (car stx) (syntax-case stx () @@ -13,7 +14,7 @@ '#,(syntax-line stx) '#,(syntax-column stx)))) (s:car x))])) - +|# (define-struct id-table-position (a b)) diff --git a/collects/syntax/private/stxparse/minimatch.ss b/collects/syntax/private/stxparse/minimatch.ss index b0cf4080db..65c3889edd 100644 --- a/collects/syntax/private/stxparse/minimatch.ss +++ b/collects/syntax/private/stxparse/minimatch.ss @@ -1,7 +1,7 @@ #lang scheme/base (require unstable/struct - (for-syntax scheme/base unstable/struct)) -(provide match) + (for-syntax scheme/base scheme/struct-info unstable/struct)) +(provide match make) (define-syntax (match stx) (syntax-case stx () @@ -25,7 +25,7 @@ ;; (match-p id Pattern SuccessExpr FailureExpr) (define-syntax (match-p stx) - (syntax-case stx (quote cons list) + (syntax-case stx (quote cons list make struct) [(match-p x wildcard success failure) (and (identifier? #'wildcard) (free-identifier=? #'wildcard #'_)) #'success] @@ -46,6 +46,27 @@ [(match-p x var success failure) (identifier? #'var) #'(let ([var x]) success)] + [(match-p x (make S p ...) success failure) + #'(match-p x (struct S (p ...)) success failure)] + [(match-p x (struct S (p ...)) success failure) + (identifier? #'S) + (let () + (define (not-a-struct) + (raise-syntax-error #f "expected struct name" #'S)) + (define si (syntax-local-value #'S not-a-struct)) + (unless (struct-info? si) + (not-a-struct)) + (let* ([si (extract-struct-info si)] + [predicate (list-ref si 2)] + [accessors (reverse (list-ref si 3))]) + (unless (andmap identifier? accessors) + (raise-syntax-error #f "struct has incomplete information" #'S)) + (with-syntax ([predicate predicate] + [(accessor ...) accessors]) + #'(if (predicate x) + (let ([y (list (accessor x) ...)]) + (match-p y (list p ...) success failure)) + failure))))] [(match-p x s success failure) (prefab-struct-key (syntax-e #'s)) (with-syntax ([key (prefab-struct-key (syntax-e #'s))] @@ -55,3 +76,7 @@ (let ([xps (cdr (vector->list (struct->vector x)))]) (match-p xps (list p ...) success failure)) failure)))])) + +(define-syntax struct + (lambda (stx) + (raise-syntax-error #f "illegal use of keyword" stx))) diff --git a/collects/syntax/private/stxparse/rep.ss b/collects/syntax/private/stxparse/rep.ss index c6f02a7256..a907511461 100644 --- a/collects/syntax/private/stxparse/rep.ss +++ b/collects/syntax/private/stxparse/rep.ss @@ -693,13 +693,13 @@ (define (check-list-pattern pattern stx) (match pattern - [#s(pat:datum _base '()) + [(make pat:datum _base '()) #t] - [#s(pat:head _base _head tail) + [(make pat:head _base _head tail) (check-list-pattern tail stx)] - [#s(pat:dots _base _head tail) + [(make pat:dots _base _head tail) (check-list-pattern tail stx)] - [#s(pat:compound _base '#:pair (list _head tail)) + [(make pat:compound _base '#:pair (list _head tail)) (check-list-pattern tail stx)] [_ (wrong-syntax stx "expected proper list pattern")])) diff --git a/collects/syntax/private/stxparse/runtime-prose.ss b/collects/syntax/private/stxparse/runtime-prose.ss index 7aa46a6933..7cec766378 100644 --- a/collects/syntax/private/stxparse/runtime-prose.ss +++ b/collects/syntax/private/stxparse/runtime-prose.ss @@ -18,7 +18,7 @@ (define (default-failure-handler stx0 f) (match (simplify-failure f) - [#s(failure x frontier expectation) + [(make failure x frontier expectation) (report-failure stx0 x (dfc->index frontier) (dfc->stx frontier) expectation)])) (define current-failure-handler @@ -68,14 +68,14 @@ ;; simplify* : Failure -> SimpleFailure (define (simplify* f) (match f - [#s(join-failures f1 f2) + [(make join-failures f1 f2) (choose-error (simplify* f1) (simplify* f2))] - [#s(failure x frontier expectation) + [(make failure x frontier expectation) (match expectation - [#s(expect:thing description '#t chained) + [(make expect:thing description '#t chained) (let ([chained* (simplify* chained)]) (match chained* - [#s(failure _ chained*-frontier chained*-expectation) + [(make failure _ chained*-frontier chained*-expectation) (cond [(ineffable? chained*-expectation) ;; If simplified chained failure is ineffable, ;; keep (& adjust) its frontier @@ -93,14 +93,14 @@ ;; FIXME: try different selection/simplification algorithms/heuristics (define (simplify-failure0 f) (match f - [#s(join-failures f1 f2) + [(make join-failures f1 f2) (choose-error (simplify-failure0 f1) (simplify-failure0 f2))] - [#s(failure x frontier expectation) + [(make failure x frontier expectation) (match expectation - [#s(expect:thing description '#t chained) + [(make expect:thing description '#t chained) (let ([chained* (simplify-failure0 chained)]) (match chained* - [#s(failure _ _ chained*-expectation) + [(make failure _ _ chained*-expectation) (cond [(ineffable? chained*-expectation) ;; If simplified chained failure is ineffable, ignore it ;; and stick to the one with the description @@ -113,7 +113,7 @@ (define (adjust-failure f base-frontier) (match f - [#s(failure x frontier expectation) + [(make failure x frontier expectation) (let ([frontier (dfc-append base-frontier frontier)]) (make-failure x frontier expectation))])) @@ -147,15 +147,15 @@ (define (for-alternative e index stx) (match e - [#s(expect:thing description transparent? chained) + [(make expect:thing description transparent? chained) (format "expected ~a" description)] - [#s(expect:atom atom) + [(make expect:atom atom) (format "expected the literal ~s" atom)] - [#s(expect:literal literal) + [(make expect:literal literal) (format "expected the literal identifier ~s" (syntax-e literal))] - [#s(expect:message message) + [(make expect:message message) (format "~a" message)] - [#s(expect:pair) + [(make expect:pair) (cond [(= index 0) "expected sequence of terms"] [else diff --git a/collects/syntax/private/stxparse/runtime.ss b/collects/syntax/private/stxparse/runtime.ss index 29ee0e8578..5b34ed2353 100644 --- a/collects/syntax/private/stxparse/runtime.ss +++ b/collects/syntax/private/stxparse/runtime.ss @@ -2,6 +2,7 @@ (require scheme/contract/base scheme/stxparam scheme/list + unstable/struct "minimatch.ss" (for-syntax scheme/base syntax/stx @@ -159,18 +160,18 @@ A Dynamic Frontier Context (DFC) is one of (define-struct dfc:pre (parent stx) #:prefab) (define-struct dfc:post (parent stx) #:prefab) -(define (dfc-empty x) (make-dfc:empty x)) +(define (dfc-empty x) (make dfc:empty x)) (define (dfc-add-car parent stx) - (make-dfc:car parent stx)) + (make dfc:car parent stx)) (define (dfc-add-cdr parent _) (match parent - [#s(dfc:cdr uberparent n) - (make-dfc:cdr uberparent (add1 n))] - [_ (make-dfc:cdr parent 1)])) + [(make dfc:cdr uberparent n) + (make dfc:cdr uberparent (add1 n))] + [_ (make dfc:cdr parent 1)])) (define (dfc-add-pre parent stx) - (make-dfc:pre parent stx)) + (make dfc:pre parent stx)) (define (dfc-add-post parent stx) - (make-dfc:post parent stx)) + (make dfc:post parent stx)) (define (dfc-add-unbox parent stx) (dfc-add-car parent stx)) @@ -181,16 +182,16 @@ A Dynamic Frontier Context (DFC) is one of (define (dfc->index dfc) (match dfc - [#s(dfc:cdr parent n) n] + [(make dfc:cdr parent n) n] [_ 0])) (define (dfc->stx dfc) (match dfc - [#s(dfc:empty stx) stx] - [#s(dfc:car parent stx) stx] - [#s(dfc:cdr parent n) (dfc->stx parent)] - [#s(dfc:pre parent stx) stx] - [#s(dfc:post parent stx) stx])) + [(make dfc:empty stx) stx] + [(make dfc:car parent stx) stx] + [(make dfc:cdr parent n) (dfc->stx parent)] + [(make dfc:pre parent stx) stx] + [(make dfc:post parent stx) stx])) ;; dfc-difference : DFC DFC -> nat ;; Returns N s.t. B = (dfc-add-cdr^N A) @@ -199,10 +200,10 @@ A Dynamic Frontier Context (DFC) is one of (error 'dfc-difference "~e is not an extension of ~e" (frontier->sexpr b) (frontier->sexpr a))) (match (list a b) - [(list #s(dfc:cdr pa na) #s(dfc:cdr pb nb)) + [(list (make dfc:cdr pa na) (make dfc:cdr pb nb)) (unless (equal? pa pb) (whoops)) (- nb na)] - [(list pa #s(dfc:cdr pb nb)) + [(list pa (make dfc:cdr pb nb)) (unless (equal? pa pb) (whoops)) nb] [_ @@ -213,16 +214,16 @@ A Dynamic Frontier Context (DFC) is one of ;; puts A at the base, B on top (define (dfc-append a b) (match b - [#s(dfc:empty stx) a] - [#s(dfc:car pb stx) (make-dfc:car (dfc-append a pb) stx)] - [#s(dfc:cdr #s(dfc:empty _) nb) + [(make dfc:empty stx) a] + [(make dfc:car pb stx) (make dfc:car (dfc-append a pb) stx)] + [(make dfc:cdr (make dfc:empty _) nb) ;; Special case to merge "consecutive" cdr frames (match a - [#s(dfc:cdr pa na) (make-dfc:cdr pa (+ na nb))] - [_ (make-dfc:cdr a nb)])] - [#s(dfc:cdr pb nb) (make-dfc:cdr (dfc-append a pb) nb)] - [#s(dfc:pre pb stx) (make-dfc:pre (dfc-append a pb) stx)] - [#s(dfc:post pb stx) (make-dfc:post (dfc-append a pb) stx)])) + [(make dfc:cdr pa na) (make dfc:cdr pa (+ na nb))] + [_ (make dfc:cdr a nb)])] + [(make dfc:cdr pb nb) (make dfc:cdr (dfc-append a pb) nb)] + [(make dfc:pre pb stx) (make dfc:pre (dfc-append a pb) stx)] + [(make dfc:post pb stx) (make dfc:post (dfc-append a pb) stx)])) ;; An Inverted DFC (IDFC) is a DFC inverted for easy comparison. @@ -230,15 +231,15 @@ A Dynamic Frontier Context (DFC) is one of (define (invert-dfc dfc) (define (invert dfc acc) (match dfc - [#s(dfc:empty _) acc] - [#s(dfc:car parent stx) - (invert parent (make-dfc:car acc stx))] - [#s(dfc:cdr parent n) - (invert parent (make-dfc:cdr acc n))] - [#s(dfc:pre parent stx) - (invert parent (make-dfc:pre acc stx))] - [#s(dfc:post parent stx) - (invert parent (make-dfc:post acc stx))])) + [(make dfc:empty _) acc] + [(make dfc:car parent stx) + (invert parent (make dfc:car acc stx))] + [(make dfc:cdr parent n) + (invert parent (make dfc:cdr acc n))] + [(make dfc:pre parent stx) + (invert parent (make dfc:pre acc stx))] + [(make dfc:post parent stx) + (invert parent (make dfc:post acc stx))])) (invert dfc (dfc-empty 'dummy))) ;; compare-idfcs : IDFC IDFC -> (one-of '< '= '>) @@ -247,28 +248,28 @@ A Dynamic Frontier Context (DFC) is one of (define (compare-idfcs a b) (match (list a b) ;; Same constructors - [(list #s(dfc:empty _) #s(dfc:empty _)) '=] - [(list #s(dfc:car pa _) #s(dfc:car pb _)) + [(list (make dfc:empty _) (make dfc:empty _)) '=] + [(list (make dfc:car pa _) (make dfc:car pb _)) (compare-idfcs pa pb)] - [(list #s(dfc:cdr pa na) #s(dfc:cdr pb nb)) + [(list (make dfc:cdr pa na) (make dfc:cdr pb nb)) (cond [(< na nb) '<] [(> na nb) '>] [(= na nb) (compare-idfcs pa pb)])] - [(list #s(dfc:pre pa _) #s(dfc:pre pb _)) + [(list (make dfc:pre pa _) (make dfc:pre pb _)) ;; FIXME: possibly just '= here, treat all sides as equiv (compare-idfcs pa pb)] - [(list #s(dfc:post pa _) #s(dfc:post pb _)) + [(list (make dfc:post pa _) (make dfc:post pb _)) ;; FIXME: possibly just '= here, treat all sides as equiv (compare-idfcs pa pb)] ;; Different constructors - [(list #s(dfc:empty _) _) '<] - [(list _ #s(dfc:empty _)) '>] - [(list #s(dfc:pre _ _) _) '<] - [(list _ #s(dfc:pre _ _)) '>] - [(list #s(dfc:car _ _) _) '<] - [(list _ #s(dfc:car _ _)) '>] - [(list #s(dfc:cdr _ _) _) '<] - [(list _ #s(dfc:cdr _ _)) '>])) + [(list (make dfc:empty _) _) '<] + [(list _ (make dfc:empty _)) '>] + [(list (make dfc:pre _ _) _) '<] + [(list _ (make dfc:pre _ _)) '>] + [(list (make dfc:car _ _) _) '<] + [(list _ (make dfc:car _ _)) '>] + [(list (make dfc:cdr _ _) _) '<] + [(list _ (make dfc:cdr _ _)) '>])) (define (idfc>? a b) (eq? (compare-idfcs a b) '>)) @@ -344,7 +345,7 @@ A Dynamic Frontier Context (DFC) is one of (lambda (f1) (let ([combining-fail (lambda (f2) - (fail (make-join-failures f1 f2)))]) + (fail (make join-failures f1 f2)))]) (try* rest-attempts combining-fail)))]) (first-attempt next-fail))))) @@ -380,7 +381,7 @@ An Expectation is one of (or/c expect? (symbols 'ineffable))) (define (merge-expectations a b) - (make-expect:disj a b)) + (make expect:disj a b)) ;; expect->alternatives : Expectation -> (listof Expectation)/#f ;; #f indicates 'ineffable somewhere in expectation @@ -541,7 +542,7 @@ An Expectation is one of (define fs (let loop ([f f]) (match f - [#s(join-failures f1 f2) + [(make join-failures f1 f2) (append (loop f1) (loop f2))] [_ (list f)]))) (case (length fs) @@ -550,20 +551,21 @@ An Expectation is one of (define (one-failure->sexpr f) (match f - [#s(failure x frontier expectation) + [(make failure x frontier expectation) `(failure ,(frontier->sexpr frontier) #:term ,(syntax->datum x) #:expected ,(expectation->sexpr expectation))])) (define (frontier->sexpr dfc) (match (invert-dfc dfc) - [#s(dfc:empty _) '()] - [#s(dfc:car p _) (cons 0 (frontier->sexpr p))] - [#s(dfc:cdr p n) (cons n (frontier->sexpr p))] - [#s(dfc:side p _) (cons 'side (frontier->sexpr p))])) + [(make dfc:empty _) '()] + [(make dfc:car p _) (cons 0 (frontier->sexpr p))] + [(make dfc:cdr p n) (cons n (frontier->sexpr p))] + [(make dfc:pre p _) (cons 'pre (frontier->sexpr p))] + [(make dfc:post p _) (cons 'post (frontier->sexpr p))])) (define (expectation->sexpr expectation) (match expectation - [#s(expect:thing thing '#t chained) - (make-expect:thing thing #t (failure->sexpr chained))] + [(make expect:thing thing '#t chained) + (make expect:thing thing #t (failure->sexpr chained))] [_ expectation])) diff --git a/collects/syntax/scribblings/module-reader.scrbl b/collects/syntax/scribblings/module-reader.scrbl index 378f19af64..e44ac24d1b 100644 --- a/collects/syntax/scribblings/module-reader.scrbl +++ b/collects/syntax/scribblings/module-reader.scrbl @@ -2,7 +2,8 @@ @(require "common.ss") @(require (for-label syntax/module-reader - (only-in scribble/reader read-syntax-inside read-inside))) + (only-in scribble/reader + read-syntax-inside read-inside))) @title[#:tag "module-reader"]{Module Reader} @@ -15,16 +16,17 @@ is the name of the module that will be used in the language position of read modules; using keywords, the resulting readers can be customized in a number of ways. -@defform*/subs[[(#%module-begin module-path) - (#%module-begin module-path reader-option ... body ....) - (#%module-begin reader-option ... body ....)] - ([reader-option (code:line #:language lang-expr) - (code:line #:read read-expr) - (code:line #:read-syntax read-syntax-expr) - (code:line #:info info-expr) - (code:line #:wrapper1 wrapper1-expr) - (code:line #:wrapper2 wrapper2-expr) - (code:line #:whole-body-readers? whole?-expr)])]{ +@defform*/subs[ + [(#%module-begin module-path) + (#%module-begin module-path reader-option ... body ....) + (#%module-begin reader-option ... body ....)] + ([reader-option (code:line #:language lang-expr) + (code:line #:read read-expr) + (code:line #:read-syntax read-syntax-expr) + (code:line #:info info-expr) + (code:line #:wrapper1 wrapper1-expr) + (code:line #:wrapper2 wrapper2-expr) + (code:line #:whole-body-readers? whole?-expr)])]{ Causes a module written in the @schememodname[syntax/module-reader] language to define and provide @schemeidfont{read} and @@ -37,26 +39,25 @@ That is, a module @scheme[_something]@scheme[/lang/reader] implemented as @schemeblock[ -(module reader syntax/module-reader - module-path) + (module reader syntax/module-reader + module-path) ] -creates a reader that converts @scheme[#,(hash-lang)_something] -into +creates a reader that converts @scheme[#,(hash-lang)_something] into @schemeblock[ -(module _name-id module-path - ....) + (module _name-id module-path + (#%module-begin ....)) ] where @scheme[_name-id] is derived from the name of the port used by -the reader. +the reader, or @scheme[anonymous-module] if the port has no name. For example, @scheme[scheme/base/lang/reader] is implemented as @schemeblock[ -(module reader syntax/module-reader - scheme/base) + (module reader syntax/module-reader + scheme/base) ] The reader functions can be customized in a number of ways, using @@ -68,10 +69,10 @@ reading. For example, you can implement a using: @schemeblock[ -(module reader syntax/module-reader - honu - #:read read-honu - #:read-syntax read-honu-syntax) + (module reader syntax/module-reader + honu + #:read read-honu + #:read-syntax read-honu-syntax) ] Similarly, the @scheme[#:info] keyword supplies a procedure to be used @@ -82,17 +83,17 @@ procedure (to be called with the key and default result for default handling). If @scheme[#:info] is not supplied, the default info-getting procedure is used. -You can also use the (optional) module @scheme[body] forms to provide more -definitions that might be needed to implement your reader functions. -For example, here is a case-insensitive reader for the +You can also use the (optional) module @scheme[body] forms to provide +more definitions that might be needed to implement your reader +functions. For example, here is a case-insensitive reader for the @scheme[scheme/base] language: @schemeblock[ -(module reader syntax/module-reader - scheme/base - #:read (wrap read) #:read-syntax (wrap read-syntax) - (define ((wrap reader) . args) - (parameterize ([read-case-sensitive #f]) (apply reader args)))) + (module reader syntax/module-reader + scheme/base + #:read (wrap read) #:read-syntax (wrap read-syntax) + (define ((wrap reader) . args) + (parameterize ([read-case-sensitive #f]) (apply reader args)))) ] In many cases, however, the standard @scheme[read] and @@ -105,11 +106,11 @@ alternative definition of the case-insensitive language using @scheme[#:wrapper1]: @schemeblock[ -(module reader syntax/module-reader - scheme/base - #:wrapper1 (lambda (t) - (parameterize ([read-case-sensitive #f]) - (t)))) + (module reader syntax/module-reader + scheme/base + #:wrapper1 (lambda (t) + (parameterize ([read-case-sensitive #f]) + (t)))) ] Note that using a @tech[#:doc refman]{readtable}, you can implement @@ -125,11 +126,11 @@ that corresponds to a file). Here is the case-insensitive implemented using this option: @schemeblock[ -(module reader syntax/module-reader - scheme/base - #:wrapper2 (lambda (in r) - (parameterize ([read-case-sensitive #f]) - (r in)))) + (module reader syntax/module-reader + scheme/base + #:wrapper2 (lambda (in r) + (parameterize ([read-case-sensitive #f]) + (r in)))) ] In some cases, the reader functions read the whole file, so there is @@ -148,10 +149,9 @@ the resulting readers: following reader defines a ``language'' that ignores the contents of the file, and simply reads files as if they were empty: @schemeblock[ - (module ignored syntax/module-reader - scheme/base - #:wrapper1 (lambda (t) (t) '())) - ] + (module ignored syntax/module-reader + scheme/base + #:wrapper1 (lambda (t) (t) '()))] Note that it is still performing the read, otherwise the module loader will complain about extra expressions.} @item{The reader function that is passed to a @scheme[#:wrapper2] @@ -168,22 +168,22 @@ scribble syntax, and the first datum in the file determines the actual language (which means that the library specification is effectively ignored): @schemeblock[ -(module reader syntax/module-reader - -ignored- - #:wrapper2 - (lambda (in rd stx?) - (let* ([lang (read in)] - [mod (parameterize ([current-readtable - (make-at-readtable)]) - (rd in))] - [mod (if stx? mod (datum->syntax #f mod))] - [r (syntax-case mod () - [(module name lang* . body) - (with-syntax ([lang (datum->syntax - #'lang* lang #'lang*)]) - (syntax/loc mod (module name lang . body)))])]) - (if stx? r (syntax->datum r)))) - (require scribble/reader)) + (module reader syntax/module-reader + -ignored- + #:wrapper2 + (lambda (in rd stx?) + (let* ([lang (read in)] + [mod (parameterize ([current-readtable + (make-at-readtable)]) + (rd in))] + [mod (if stx? mod (datum->syntax #f mod))] + [r (syntax-case mod () + [(module name lang* . body) + (with-syntax ([lang (datum->syntax + #'lang* lang #'lang*)]) + (syntax/loc mod (module name lang . body)))])]) + (if stx? r (syntax->datum r)))) + (require scribble/reader)) ] This ability to change the language position in the resulting module @@ -191,22 +191,33 @@ expression can be useful in cases such as the above, where the base language module is chosen based on the input. To make this more convenient, you can omit the @scheme[module-path] and instead specify it via a @scheme[#:language] expression. This expression can evaluate -to a datum or syntax object that is used as a language, or it can evaluate to a thunk. -In the latter case, the thunk is invoked to obtain such a datum -before reading the module body begins, in a dynamic extent where -@scheme[current-input-port] is the source input. A syntax object is converted -using @scheme[syntax->datum] when a datum is needed (for @scheme[read] instead of @scheme[read-syntax]). -Using @scheme[#:language], the last -example above can be written more concisely: +to a datum or syntax object that is used as a language, or it can +evaluate to a thunk. In the latter case, the thunk is invoked to +obtain such a datum before reading the module body begins, in a +dynamic extent where @scheme[current-input-port] is the source +input. A syntax object is converted using @scheme[syntax->datum] when +a datum is needed (for @scheme[read] instead of @scheme[read-syntax]). +Using @scheme[#:language], the last example above can be written more +concisely: + @schemeblock[ -(module reader syntax/module-reader - #:language read - #:wrapper2 (lambda (in rd stx?) - (parameterize ([current-readtable - (make-at-readtable)]) - (rd in))) - (require scribble/reader)) + (module reader syntax/module-reader + #:language read + #:wrapper2 (lambda (in rd stx?) + (parameterize ([current-readtable + (make-at-readtable)]) + (rd in))) + (require scribble/reader)) ] + + +Note: if such whole-body reader functions return a list with a single +expression that begins with @scheme[#%module-begin], then the +@scheme[syntax/module-reader] language will not inappropriately add +another. This for backwards-compatibility with older code: having a +whole-body reader functions or wrapper functions that return a +@scheme[#%module-begin]-wrapped body is deprectaed. + } @@ -227,7 +238,8 @@ procedures chains to another language that is specified in an input stream. @margin-note{The @schememodname[at-exp], @schememodname[reader], and -@schememodname[planet] languages are implemented using this function.} + @schememodname[planet] languages are implemented using this + function.} The generated functions expect a target language description in the input stream that is provided to @scheme[read-spec]. The default @@ -239,8 +251,9 @@ reader exception is raised, and @scheme[path-desc-str] is used as a description of the expected language form in the error message. @margin-note{The @schememodname[reader] language supplies -@scheme[read] for @scheme[read-spec]. The @schememodname[at-exp] and -@schememodname[planet] languages use the default @scheme[read-spec].} + @scheme[read] for @scheme[read-spec]. The @schememodname[at-exp] and + @schememodname[planet] languages use the default + @scheme[read-spec].} The result of @scheme[read-spec] is converted to a module path using @scheme[module-path-parser]. If @scheme[module-path-parser] produces @@ -256,9 +269,9 @@ passed to @scheme[convert-read], @scheme[convert-read-syntax], or @scheme[convert-get-info], respectively. @margin-note{The @schememodname[at-exp] language supplies -@scheme[convert-read] and @scheme[convert-read-syntax] to add -@"@"-expression support to the current readtable before chaining to -the given procedures.} + @scheme[convert-read] and @scheme[convert-read-syntax] to add + @"@"-expression support to the current readtable before chaining to + the given procedures.} The procedures generated by @scheme[make-meta-reader] are not meant for use with the @schememodname[syntax/module-reader] language; they @@ -277,14 +290,14 @@ are meant to be exported directly.} @emph{This function is deprecated; the @schememodname[syntax/module-reader] language can be adapted using the -various keywords to arbitrary readers, and please use it instead.} +various keywords to arbitrary readers; please use it instead.} Repeatedly calls @scheme[read] on @scheme[in] until an end of file, collecting the results in order into @scheme[_lst], and derives a -@scheme[_name-id] from @scheme[(object-name in)]. The last five +@scheme[_name-id] from @scheme[(object-name in)]. The last five arguments are used to construct the syntax object for the language position of the module. The result is roughly @schemeblock[ -`(module ,_name-id ,mod-path ,@_lst) + `(module ,_name-id ,mod-path ,@_lst) ]} diff --git a/collects/teachpack/2htdp/scribblings/image-gen.ss b/collects/teachpack/2htdp/scribblings/image-gen.ss index cbaf4b9c66..753806ba2e 100644 --- a/collects/teachpack/2htdp/scribblings/image-gen.ss +++ b/collects/teachpack/2htdp/scribblings/image-gen.ss @@ -28,7 +28,13 @@ (define (handle-image exp) (printf ".") (flush-output) - (let ([result (parameterize ([current-namespace image-ns]) (eval exp))]) + (let ([result + (with-handlers ([exn:fail? + (λ (x) + (printf "\nerror evaluating:\n") + (pretty-print exp) + (raise x))]) + (parameterize ([current-namespace image-ns]) (eval exp)))]) (cond [(image? result) (let ([fn (exp->filename exp)]) diff --git a/collects/teachpack/2htdp/scribblings/image-toc.ss b/collects/teachpack/2htdp/scribblings/image-toc.ss index 5ff0c76d67..314d641b85 100644 --- a/collects/teachpack/2htdp/scribblings/image-toc.ss +++ b/collects/teachpack/2htdp/scribblings/image-toc.ss @@ -8,8 +8,8 @@ (list (list '(image-height (rectangle 100 100 "solid" "black")) 'val 100) (list '(image-baseline (rectangle 100 100 "solid" "black")) 'val 100) - (list '(image-height (text "Hello" 24 "black")) 'val 24.0) - (list '(image-baseline (text "Hello" 24 "black")) 'val 18.0) + (list '(image-height (text "Hello" 24 "black")) 'val 41.0) + (list '(image-baseline (text "Hello" 24 "black")) 'val 31.0) (list '(image-height (overlay (circle 20 "solid" "orange") (circle 30 "solid" "purple"))) @@ -114,6 +114,76 @@ (ellipse 20 10 "solid" "black")) 'image "28c73238138.png") + (list + '(underlay/xy + (underlay/xy + (ellipse 40 40 "solid" "gray") + 10 + 15 + (ellipse 10 10 "solid" "forestgreen")) + 20 + 15 + (ellipse 10 10 "solid" "forestgreen")) + 'image + "201c231dce2.png") + (list + '(underlay/xy + (rectangle 20 20 "solid" "red") + -20 + -20 + (rectangle 20 20 "solid" "black")) + 'image + "42f9f9e4cf.png") + (list + '(underlay/xy + (rectangle 20 20 "solid" "red") + 20 + 20 + (rectangle 20 20 "solid" "black")) + 'image + "157ab5efca7.png") + (list + '(underlay/xy + (rectangle 20 20 "outline" "black") + 20 + 0 + (rectangle 20 20 "outline" "black")) + 'image + "26bd803042c.png") + (list + '(underlay/align + "right" + "top" + (rectangle 50 50 "solid" "seagreen") + (rectangle 40 40 "solid" "silver") + (rectangle 30 30 "solid" "seagreen") + (rectangle 20 20 "solid" "silver")) + 'image + "ff2fcb7b87.png") + (list + '(underlay/align + "middle" + "middle" + (rectangle 30 60 "solid" "orange") + (ellipse 60 30 "solid" "purple")) + 'image + "2d1e52503d7.png") + (list + '(underlay + (ellipse 10 60 "solid" "red") + (ellipse 20 50 "solid" "black") + (ellipse 30 40 "solid" "red") + (ellipse 40 30 "solid" "black") + (ellipse 50 20 "solid" "red") + (ellipse 60 10 "solid" "black")) + 'image + "28253f4c3c.png") + (list + '(underlay + (rectangle 30 60 "solid" "orange") + (ellipse 60 30 "solid" "purple")) + 'image + "9858b8d5d.png") (list '(overlay/xy (overlay/xy diff --git a/collects/teachpack/2htdp/scribblings/image.scrbl b/collects/teachpack/2htdp/scribblings/image.scrbl index 3698a01242..bc1f123196 100644 --- a/collects/teachpack/2htdp/scribblings/image.scrbl +++ b/collects/teachpack/2htdp/scribblings/image.scrbl @@ -318,6 +318,70 @@ other. The top and bottom pair of angles is @scheme[angle] and the left and righ (ellipse 10 10 "solid" "forestgreen"))] } +@defproc[(underlay [i1 image?] [i2 image?] [is image?] ...) image?]{ + Underlays all of its arguments building a single image. + + It behaves like @scheme[overlay], but with the arguments in the reverse order. + That is, the first argument goes + underneath of the second argument, which goes underneath the third argument, etc. + The images are all lined up on their upper-left corners. + + @image-examples[(underlay (rectangle 30 60 "solid" "orange") + (ellipse 60 30 "solid" "purple")) + (underlay (ellipse 10 60 "solid" "red") + (ellipse 20 50 "solid" "black") + (ellipse 30 40 "solid" "red") + (ellipse 40 30 "solid" "black") + (ellipse 50 20 "solid" "red") + (ellipse 60 10 "solid" "black"))] + + } + +@defproc[(underlay/align [x-place x-place?] [y-place y-place?] [i1 image?] [i2 image?] [is image?] ...) image?]{ + Underlays all of its image arguments, much like the @scheme[underlay] function, but using + @scheme[x-place] and @scheme[y-place] to determine where the images are lined up. For example, if + @scheme[x-place] and @scheme[y-place] are both @scheme["middle"], then the images are lined up + on their centers. + + @image-examples[(underlay/align "middle" "middle" + (rectangle 30 60 "solid" "orange") + (ellipse 60 30 "solid" "purple")) + (underlay/align "right" "top" + (rectangle 50 50 "solid" "seagreen") + (rectangle 40 40 "solid" "silver") + (rectangle 30 30 "solid" "seagreen") + (rectangle 20 20 "solid" "silver"))] + + + } + +@defproc[(underlay/xy [i1 image?] [x real?] [y real?] [i2 image?]) image?]{ + Constructs an image by underlaying @scheme[i1] underneath of @scheme[i2] after + shifting @scheme[i2] over by @scheme[x] pixels to the right and @scheme[y] + pixels down. + + This is the same as @scheme[(overlay/xy i2 (- x) (- y) i1)]. + + @image-examples[(underlay/xy (rectangle 20 20 "outline" "black") + 20 0 + (rectangle 20 20 "outline" "black")) + (underlay/xy (rectangle 20 20 "solid" "red") + 20 20 + (rectangle 20 20 "solid" "black")) + (underlay/xy (rectangle 20 20 "solid" "red") + -20 -20 + (rectangle 20 20 "solid" "black")) + (underlay/xy + (underlay/xy (ellipse 40 40 "solid" "gray") + 10 + 15 + (ellipse 10 10 "solid" "forestgreen")) + 20 + 15 + (ellipse 10 10 "solid" "forestgreen"))] +} + + @defproc[(beside [i1 image?] [i2 image?] [is image?] ...) image?]{ Constructs an image by placing all of the argument images in a horizontal row, aligned along their top edges. diff --git a/collects/teachpack/2htdp/scribblings/img/157ab5efca7.png b/collects/teachpack/2htdp/scribblings/img/157ab5efca7.png new file mode 100644 index 0000000000..59966a6bc9 Binary files /dev/null and b/collects/teachpack/2htdp/scribblings/img/157ab5efca7.png differ diff --git a/collects/teachpack/2htdp/scribblings/img/201c231dce2.png b/collects/teachpack/2htdp/scribblings/img/201c231dce2.png new file mode 100644 index 0000000000..0f7fef2922 Binary files /dev/null and b/collects/teachpack/2htdp/scribblings/img/201c231dce2.png differ diff --git a/collects/teachpack/2htdp/scribblings/img/26bd803042c.png b/collects/teachpack/2htdp/scribblings/img/26bd803042c.png new file mode 100644 index 0000000000..ba29f9ce76 Binary files /dev/null and b/collects/teachpack/2htdp/scribblings/img/26bd803042c.png differ diff --git a/collects/teachpack/2htdp/scribblings/img/28253f4c3c.png b/collects/teachpack/2htdp/scribblings/img/28253f4c3c.png new file mode 100644 index 0000000000..b9aa3d8d5f Binary files /dev/null and b/collects/teachpack/2htdp/scribblings/img/28253f4c3c.png differ diff --git a/collects/teachpack/2htdp/scribblings/img/2d1e52503d7.png b/collects/teachpack/2htdp/scribblings/img/2d1e52503d7.png new file mode 100644 index 0000000000..3d05fa71d1 Binary files /dev/null and b/collects/teachpack/2htdp/scribblings/img/2d1e52503d7.png differ diff --git a/collects/teachpack/2htdp/scribblings/img/42f9f9e4cf.png b/collects/teachpack/2htdp/scribblings/img/42f9f9e4cf.png new file mode 100644 index 0000000000..6f62addfae Binary files /dev/null and b/collects/teachpack/2htdp/scribblings/img/42f9f9e4cf.png differ diff --git a/collects/teachpack/2htdp/scribblings/img/9858b8d5d.png b/collects/teachpack/2htdp/scribblings/img/9858b8d5d.png new file mode 100644 index 0000000000..d3abd4688e Binary files /dev/null and b/collects/teachpack/2htdp/scribblings/img/9858b8d5d.png differ diff --git a/collects/teachpack/2htdp/scribblings/img/ff2fcb7b87.png b/collects/teachpack/2htdp/scribblings/img/ff2fcb7b87.png new file mode 100644 index 0000000000..0930b8b91a Binary files /dev/null and b/collects/teachpack/2htdp/scribblings/img/ff2fcb7b87.png differ diff --git a/collects/teachpack/2htdp/scribblings/universe.scrbl b/collects/teachpack/2htdp/scribblings/universe.scrbl index be34e073f1..c957110bd4 100644 --- a/collects/teachpack/2htdp/scribblings/universe.scrbl +++ b/collects/teachpack/2htdp/scribblings/universe.scrbl @@ -443,6 +443,16 @@ All @tech{MouseEvent}s are represented via strings: @item{ +@defproc[(stop-with [w (unsyntax @tech{WorldState})]) (stop-with (unsyntax @tech{WorldState}))]{signals to +DrScheme that the current world program should shut down. That is, any +handler may return @scheme[(stop-with w)] provided @scheme[w] is a +@tech{WorldState}. If it does, the state of the world becomes @scheme[w] +but @scheme[big-bang] will close down all event handling.} + +} + +@item{ + @defform[(check-with world-expr?) #:contracts ([world-expr? (-> Any boolean?)])]{ diff --git a/collects/tests/drscheme/randomly-click-language-dialog.ss b/collects/tests/drscheme/randomly-click-language-dialog.ss new file mode 100644 index 0000000000..d63009c9e1 --- /dev/null +++ b/collects/tests/drscheme/randomly-click-language-dialog.ss @@ -0,0 +1,3 @@ +#lang scheme +(require "randomly-click.ss") +(go 'language-dialog) diff --git a/collects/tests/drscheme/randomly-click-preferences.ss b/collects/tests/drscheme/randomly-click-preferences.ss new file mode 100644 index 0000000000..ae40c20e8c --- /dev/null +++ b/collects/tests/drscheme/randomly-click-preferences.ss @@ -0,0 +1,3 @@ +#lang scheme +(require "randomly-click.ss") +(go 'preferences-dialog) diff --git a/collects/tests/drscheme/randomly-click.ss b/collects/tests/drscheme/randomly-click.ss new file mode 100644 index 0000000000..720a5f7774 --- /dev/null +++ b/collects/tests/drscheme/randomly-click.ss @@ -0,0 +1,172 @@ +#lang scheme/gui +(require framework) +(provide go) + +(define numButtonsToPush 200) + +;;find-all-actions: area -> (listof (-> void)) +(define (find-all-actions area) + (cond + [(is-a? area area-container<%>) + (apply append (map find-all-actions (send area get-children)))] + [(and (is-a? area button%) + (send area is-enabled?) + (send area is-shown?)) + (list (case-lambda + [(x) (format "button ~s" (send area get-label))] + [() (test:button-push area)]))] + [(and (is-a? area check-box%) + (send area is-enabled?)) + (let ([func + (λ (which-way) + (case-lambda + [(x) (format "checkbox ~s" (send area get-label))] + [() (test:set-check-box! area which-way)]))]) + (list (func #t) (func #f)))] + [(and (is-a? area radio-box%) + (send area is-enabled?)) + (for/list ([i (in-range 0 (send area get-number))]) + (case-lambda + [(x) (format "radiobox, item ~s" (send area get-item-label i))] + [() (test:set-radio-box! area i)]))] + [else '()])) + +;;find-random-button: area -> random element of the buttons in area +;;return #f if there is no buttons in area +(define (find-random-action area) + (define buttons (find-all-actions area)) + (cond + ;;Area with no buttons + [(null? buttons) #f] + [else (list-ref buttons (random (length buttons)))])) + +;; Trace the path to the area back to a base-frame +(define (trace-area area base-frame) + (cond + [(eq? area base-frame) + (list base-frame)] + [else + (append (trace-area (send area get-parent) base-frame) (list area))] + )) + +;;toy print-label function +(define (print-label area) + (cond + [(is-a? area tab-panel%) + ;(send area get-item-label (send area get-selection))] + (send area get-item-label 0)] + [(is-a? area vertical-panel%) + "Vert-Panel"] + [(is-a? area horizontal-panel%) + "Hort-Panel"] + [(is-a? area vertical-pane%) + "Vert-Pane"] + [(is-a? area horizontal-pane%) + "Hort-Pane"] + [else + (send area get-label)])) + +(define (g open-dialog) + (thread + (λ () + (let ((base-window (get-top-level-focus-window))) + (open-dialog) + (wait-for-different-frame base-window) + (let loop ([n numButtonsToPush] + [actions '()]) + (cond + [(zero? n) + (printf "\n") + (exit 0)] + [else + + (printf "~a " n) + (when (= 1 (modulo n 10)) (printf "\n")) + (flush-output) + + (let ((window (get-top-level-focus-window))) + (cond + ;; Back to base-window is not interesting, Reopen + [(eq? base-window window) + (open-dialog) + (wait-for-different-frame base-window) + (loop (- n 1) actions)] + + ;; get-top-level-focus-window returns #f may imply window not in current eventspace + ;; but it also might just mean we didn't look into subeventspaces(?) + ;; or that we need to wait for something to happen in the GUI(?) + [(eq? window #f) + (sleep .1) + (loop (- n 1) actions)] + + [else + ;; print out the button before the button is pushed + ;; Using the toy print-label function + ;; because some of the parents may not be sent with get-label e.g. vertical-pane% + ;(print (map print-label (trace-area button window))) + (let ([action (find-random-action window)]) + (cond + [action + (with-handlers ((exn:fail? (λ (x) + (fprintf (current-error-port) + "\nExecution fail: Bug? transcript of ~a clicking follows\n" + (send window get-label)) + (apply show-log (cons action actions)) + (raise x)))) + (action)) + (loop (- n 1) (cons action actions))] + [else + (fprintf (current-error-port) "\nExists/Meets window with no button: Bug? -> Reopen Dialog") + (open-dialog) + (loop n actions)]))]))])))))) + +(define (show-log . actions) + (for ((action (in-list actions))) + (fprintf (current-error-port) + " ~a\n" + (action 'ignored)))) + +;; the splash screen is in a separate eventspace so wont' show up. +(define (wait-for-first-frame) + (let loop () + (let ([tlws (get-top-level-windows)]) + (cond + [(null? tlws) + (sleep 1/10) + (loop)] + [else (car tlws)])))) + + +(define (wait-for-different-frame win) + (let loop ([n 1000]) + (cond + [(zero? n) + (error 'wait-for-different-frame "never got that new window, only this one: ~s" win)] + [else + (let ([tlw (get-top-level-focus-window)]) + (when (eq? win tlw) + (sleep 1/10) + (loop (- n 1))))]))) + +(define orig-display-handler (error-display-handler)) + +(define (go which-dialog) + (dynamic-require 'drscheme #f) + + ;; reset the uncaught exception handler to be sure we kill everything (drscheme sets it) + (uncaught-exception-handler + (λ (x) + (if (exn? x) + (orig-display-handler (exn-message x) x) + (fprintf (current-error-port) "uncaught exception ~s\n" x)) + (exit 1))) + + (void + (thread + (λ () + (define drs (wait-for-first-frame)) + (case which-dialog + [(language-dialog) + (g (λ () (test:menu-select "Language" "Choose Language...")))] + [(preferences-dialog) + (g (λ () (preferences:show-dialog)))]))))) diff --git a/collects/tests/mzscheme/benchmarks/shootout/mandelbrot.ss b/collects/tests/mzscheme/benchmarks/shootout/mandelbrot.ss index 3e8306c7b8..37b3526660 100644 --- a/collects/tests/mzscheme/benchmarks/shootout/mandelbrot.ss +++ b/collects/tests/mzscheme/benchmarks/shootout/mandelbrot.ss @@ -36,7 +36,7 @@ ((> (+ zrq ziq) +limit-sqr+) 0) (else (loop (add1 i) (+ (- zrq ziq) cr) - (+ (* 2.0 (* zr zi)) ci))))))))) + (+ (* 2.0 zr zi) ci))))))))) ;; ------------------------------- diff --git a/collects/tests/mzscheme/benchmarks/shootout/nbody.ss b/collects/tests/mzscheme/benchmarks/shootout/nbody.ss index f3c3199ddd..3311cc344e 100644 --- a/collects/tests/mzscheme/benchmarks/shootout/nbody.ss +++ b/collects/tests/mzscheme/benchmarks/shootout/nbody.ss @@ -93,9 +93,10 @@ Correct output N = 1000 is (if (null? o) e (let* ([o1 (car o)] - [e (+ e (* (* 0.5 (body-mass o1)) - (+ (+ (* (body-vx o1) (body-vx o1)) - (* (body-vy o1) (body-vy o1))) + [e (+ e (* 0.5 + (body-mass o1) + (+ (* (body-vx o1) (body-vx o1)) + (* (body-vy o1) (body-vy o1)) (* (body-vz o1) (body-vz o1)))))]) (let loop-i ([i (cdr o)] [e e]) (if (null? i) @@ -104,7 +105,7 @@ Correct output N = 1000 is [dx (- (body-x o1) (body-x i1))] [dy (- (body-y o1) (body-y i1))] [dz (- (body-z o1) (body-z i1))] - [dist (sqrt (+ (+ (* dx dx) (* dy dy)) (* dz dz)))] + [dist (sqrt (+ (* dx dx) (* dy dy) (* dz dz)))] [e (- e (/ (* (body-mass o1) (body-mass i1)) dist))]) (loop-i (cdr i) e)))))))) @@ -126,7 +127,7 @@ Correct output N = 1000 is [dx (- o1x (body-x i1))] [dy (- o1y (body-y i1))] [dz (- o1z (body-z i1))] - [dist2 (+ (+ (* dx dx) (* dy dy)) (* dz dz))] + [dist2 (+ (* dx dx) (* dy dy) (* dz dz))] [mag (/ +dt+ (* dist2 (sqrt dist2)))] [dxmag (* dx mag)] [dymag (* dy mag)] diff --git a/collects/tests/mzscheme/compile.ss b/collects/tests/mzscheme/compile.ss index 2137a8a52f..34a76a5c53 100644 --- a/collects/tests/mzscheme/compile.ss +++ b/collects/tests/mzscheme/compile.ss @@ -8,7 +8,7 @@ 'compile-load #f (lambda () - (namespace-set-variable-value! 'compile-load "quiet.ss"))) + (namespace-set-variable-value! 'compile-load "mzq.ss"))) (define file (if #f @@ -64,7 +64,7 @@ [(x next-eval) (if (or (compiled-expression? x) (and (syntax? x) (compiled-expression? (syntax-e x))) - (current-module-name-prefix)) + (current-module-declare-name)) (next-eval x) (begin ;; (fprintf file ": ~a~n" +) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 89e6e5d1b7..2769651825 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -2060,6 +2060,12 @@ x) '(2)) + (test/spec-passed + 'or/c-hmm + (let ([funny/c (or/c (and/c procedure? (-> any)) (listof (-> number?)))]) + (contract (-> funny/c any) void 'pos 'neg))) + + ; ; @@ -2282,7 +2288,53 @@ 'neg) 'x) 1) - + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; make-proj-contract + ;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (contract-eval + '(define proj:add1->sub1 + (make-proj-contract + 'proj:add1->sub1 + (lambda (pos neg src name blame) + (lambda (f) + (unless (and (procedure? f) (procedure-arity-includes? f 1)) + (raise-contract-error f src pos name + "expected a unary function, got: ~e" + f)) + (lambda (x) + (unless (and (integer? x) (exact? x)) + (raise-contract-error x src neg name + "expected an integer, got: ~e" + x)) + (let* ([y (f (add1 x))]) + (unless (and (integer? y) (exact? y)) + (raise-contract-error y src pos name + "expected an integer, got: ~e" + y)) + (sub1 y))))) + (lambda (f) + (and (procedure? f) (procedure-arity-includes? f 1)))))) + + (test/spec-passed/result + 'make-proj-contract-1 + '((contract proj:add1->sub1 sqrt 'pos 'neg) 15) + 3) + + (test/pos-blame + 'make-proj-contract-2 + '(contract proj:add1->sub1 'dummy 'pos 'neg)) + + (test/pos-blame + 'make-proj-contract-3 + '((contract proj:add1->sub1 (lambda (x) 'dummy) 'pos 'neg) 2)) + + (test/neg-blame + 'make-proj-contract-4 + '((contract proj:add1->sub1 sqrt 'pos 'neg) 'dummy)) ; ; @@ -5200,6 +5252,88 @@ ;; end of define-opt/c ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; opt/c and blame + ;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (contract-eval + '(begin + + (define proj:blame/c + (make-proj-contract + 'proj:blame/c + (lambda (pos neg src name blame) + (lambda (x) + (if blame 'positive 'negative))) + (lambda (x) #t))) + + (define call*0 'dummy) + (define (call*1 x0) x0) + (define (call*2 f1 x0) (f1 x0)) + (define (call*3 f2 x1 x0) (f2 x1 x0)))) + + (test/spec-passed/result + 'opt/c-blame-0 + '((contract + (-> (-> (-> proj:blame/c any/c) any/c any/c) (-> any/c any/c) any/c any/c) + call*3 + 'pos + 'neg) + call*2 + call*1 + call*0) + 'negative) + + (test/spec-passed/result + 'opt/c-blame-1 + '((contract + (opt/c (-> (-> (-> proj:blame/c any/c) any/c any/c) (-> any/c any/c) any/c any/c)) + call*3 + 'pos + 'neg) + call*2 + call*1 + call*0) + 'negative) + + (test/spec-passed/result + 'opt/c-blame-2 + '((contract + (-> (opt/c (-> (-> proj:blame/c any/c) any/c any/c)) (-> any/c any/c) any/c any/c) + call*3 + 'pos + 'neg) + call*2 + call*1 + call*0) + 'negative) + + (test/spec-passed/result + 'opt/c-blame-3 + '((contract + (-> (-> (opt/c (-> proj:blame/c any/c)) any/c any/c) (-> any/c any/c) any/c any/c) + call*3 + 'pos + 'neg) + call*2 + call*1 + call*0) + 'negative) + + (test/spec-passed/result + 'opt/c-blame-4 + '((contract + (-> (-> (-> (opt/c proj:blame/c) any/c) any/c any/c) (-> any/c any/c) any/c any/c) + call*3 + 'pos + 'neg) + call*2 + call*1 + call*0) + 'negative) ;; NOT YET RELEASED #; diff --git a/collects/tests/mzscheme/htdp-image.ss b/collects/tests/mzscheme/htdp-image.ss index 45dd5a6525..995c2ad941 100644 --- a/collects/tests/mzscheme/htdp-image.ss +++ b/collects/tests/mzscheme/htdp-image.ss @@ -830,6 +830,10 @@ 'ph-text (list (pinhole-x (text "10" 10 'red)) (pinhole-y (text "10" 10 'red)))) +(test (list 0 0) + 'ph-text + (list (pinhole-x (text "" 10 'red)) + (pinhole-y (text "" 10 'red)))) (test (list 3 3) 'ph-add-line diff --git a/collects/tests/mzscheme/math.ss b/collects/tests/mzscheme/math.ss index 51f6bc5b2a..1ca07b9eea 100644 --- a/collects/tests/mzscheme/math.ss +++ b/collects/tests/mzscheme/math.ss @@ -14,6 +14,8 @@ (test 3 order-of-magnitude 5000) (test 3 order-of-magnitude 9999) (test 4 order-of-magnitude 10000) +(test -2 order-of-magnitude 1/100) +(test -3 order-of-magnitude 1/101) (test 25 sqr 5) (test 25 sqr -5) diff --git a/collects/tests/mzscheme/module-reader.ss b/collects/tests/mzscheme/module-reader.ss index a2d7e5660f..198d66f723 100644 --- a/collects/tests/mzscheme/module-reader.ss +++ b/collects/tests/mzscheme/module-reader.ss @@ -20,7 +20,8 @@ ;; plain version (module r0 syntax/module-reader scheme/base) (test-both '(r0) "#reader '~s (define FoO #:bAr)" - '(module page scheme/base (define FoO #:bAr))) + '(module anonymous-module scheme/base + (#%module-begin (define FoO #:bAr)))) ;; using a simple wrapper to get a case-insensitive reader (module r1 syntax/module-reader scheme/base @@ -35,7 +36,8 @@ (parameterize ([read-case-sensitive #f]) (apply reader args)))) ;; (test-both '(r1 r2 r3) "#reader '~s (define FoO #:bAr)" - '(module page scheme/base (define foo #:bar))) + '(module anonymous-module scheme/base + (#%module-begin (define foo #:bar)))) ;; add something to the result (module r4 syntax/module-reader zzz @@ -45,7 +47,8 @@ #:wrapper1 (lambda (t stx?) (cons (if stx? #'foo 'foo) (t)))) ;; (test-both '(r4 r5) "#reader '~s (define foo #:bar)" - '(module page zzz foo (define foo #:bar))) + '(module anonymous-module zzz + (#%module-begin foo (define foo #:bar)))) ;; make an empty module, after reading the contents (module r6 syntax/module-reader zzz @@ -56,14 +59,16 @@ ;; forget about the input -- just return a fixed empty input module (module r8 syntax/module-reader whatever #:wrapper2 (lambda (in rd) - (if (syntax? (rd in)) #'(module page zzz) '(module page zzz)))) + (if (syntax? (rd in)) + #'(module anonymous-module zzz (#%module-begin)) + '(module anonymous-module zzz (#%module-begin))))) ;; the same, the easy way (module r9 syntax/module-reader #:language (lambda () 'zzz) #:wrapper1 (lambda (t) '())) ;; (test-both '(r6 r7 r8 r9) "#reader '~s (define foo #:bar)" - '(module page zzz)) + '(module anonymous-module zzz (#%module-begin))) ;; a module that uses the scribble syntax with a specified language (module r10 syntax/module-reader -ignored- @@ -89,9 +94,11 @@ (require scribble/reader)) ;; (test-both '(r10 r11) "#reader '~s scheme/base (define foo 1)" - '(module page scheme/base (define foo 1))) + '(module anonymous-module scheme/base + (#%module-begin (define foo 1)))) (test-both '(r10 r11) "#reader '~s scheme/base @define[foo]{one}" - '(module page scheme/base (define foo "one"))) + '(module anonymous-module scheme/base + (#%module-begin (define foo "one")))) ;; ---------------------------------------- diff --git a/collects/tests/mzscheme/optimize.ss b/collects/tests/mzscheme/optimize.ss index f221dca2d6..00b3e2ba15 100644 --- a/collects/tests/mzscheme/optimize.ss +++ b/collects/tests/mzscheme/optimize.ss @@ -89,17 +89,41 @@ (bin0 iv op +nan.0 (exact->inexact arg2)) (unless (eq? op 'eq?) (bin0 iv op +nan.0 +nan.0))))] - [tri0 (lambda (v op get-arg1 arg2 arg3 check-effect) + [tri0 (lambda (v op get-arg1 arg2 arg3 check-effect #:wrap [wrap values]) ;; (printf "Trying ~a ~a ~a\n" op (get-arg1) arg2 arg3); - (let ([name `(,op ,get-arg1 ,arg2, arg3)]) - (test v name ((eval `(lambda (x) (,op x ,arg2 ,arg3))) (get-arg1))) + (let ([name `(,op ,get-arg1 ,arg2, arg3)] + [get-arg2 (lambda () arg2)] + [get-arg3 (lambda () arg3)]) + (test v name ((eval `(lambda (x) ,(wrap `(,op x ,arg2 ,arg3)))) (get-arg1))) (check-effect) - (test v name ((eval `(lambda (x) (,op (,get-arg1) x ,arg3))) arg2)) + (test v name ((eval `(lambda (x) ,(wrap `(,op (,get-arg1) x ,arg3)))) arg2)) (check-effect) - (test v name ((eval `(lambda (x) (,op (,get-arg1) ,arg2 x))) arg3)) + (test v name ((eval `(lambda (x) ,(wrap `(,op x (,get-arg2) ,arg3)))) (get-arg1))) (check-effect) - (test v name ((eval `(lambda (x y z) (,op x y z))) (get-arg1) arg2 arg3)) + (test v name ((eval `(lambda (x) ,(wrap `(,op (,get-arg1) (,get-arg2) x)))) arg3)) + (check-effect) + (test v name ((eval `(lambda () ,(wrap `(,op (,get-arg1) (,get-arg2) (,get-arg3))))))) + (check-effect) + (test v name ((eval `(lambda (x) ,(wrap `(,op (,get-arg1) ,arg2 x)))) arg3)) + (check-effect) + (test v name ((eval `(lambda (x y) ,(wrap `(,op (,get-arg1) x y)))) arg2 arg3)) + (check-effect) + (eval `(define _arg2 ,arg2)) + (test v name ((eval `(lambda (y) ,(wrap `(,op (,get-arg1) _arg2 y)))) arg3)) + (check-effect) + (test v name ((eval `(lambda (x y z) ,(wrap `(,op x y z)))) (get-arg1) arg2 arg3)) (check-effect)))] + [tri (lambda (v op get-arg1 arg2 arg3 check-effect #:wrap [wrap values]) + (define (e->i n) (if (number? n) (exact->inexact n) n)) + (tri0 v op get-arg1 arg2 arg3 check-effect #:wrap wrap) + (tri0 (e->i v) op (lambda () (exact->inexact (get-arg1))) (exact->inexact arg2) (exact->inexact arg3) check-effect + #:wrap wrap) + (tri0 (e->i v) op get-arg1 (exact->inexact arg2) arg3 check-effect + #:wrap wrap))] + [tri-if (lambda (v op get-arg1 arg2 arg3 check-effect) + (tri v op get-arg1 arg2 arg3 check-effect) + (tri (if v 'true 'false) op get-arg1 arg2 arg3 check-effect + #:wrap (lambda (e) `(if ,e 'true 'false))))] [tri-exact (lambda (v op get-arg1 arg2 arg3 check-effect 3rd-all-ok?) (check-error-message op (eval `(lambda (x) (,op x ,arg2 ,arg3)))) (check-error-message op (eval `(lambda (x) (,op (,get-arg1) x ,arg3)))) @@ -188,12 +212,18 @@ (bin #t '< -200 100) (bin #f '< 100 -200) (bin #t '< 1 (expt 2 30)) + (tri-if #t '< (lambda () 1) 2 3 void) + (tri-if #f '< (lambda () 1) 3 3 void) + (tri-if #f '< (lambda () 1) -1 3 void) (bin #t '<= 100 200) (bin #f '<= 200 100) (bin #t '<= 100 100) (bin #t '<= -200 100) (bin #f '<= 100 -200) + (tri-if #t '<= (lambda () 1) 2 3 void) + (tri-if #t '<= (lambda () 1) 3 3 void) + (tri-if #f '<= (lambda () 1) -1 3 void) (bin #f '> 100 200) (bin #t '> 200 100) @@ -201,18 +231,28 @@ (bin #f '> -200 100) (bin #t '> 100 -200) (bin #f '> 1 (expt 2 30)) + (tri-if #t '> (lambda () 3) 2 1 void) + (tri-if #f '> (lambda () 3) 3 1 void) + (tri-if #f '> (lambda () 3) -1 1 void) (bin #f '>= 100 200) (bin #t '>= 200 100) (bin #t '>= 100 100) (bin #f '>= -200 100) (bin #t '>= 100 -200) + (tri-if #t '>= (lambda () 3) 2 1 void) + (tri-if #t '>= (lambda () 3) 3 1 void) + (tri-if #f '>= (lambda () 3) -1 1 void) (bin #f '= 100 200) (bin #f '= 200 100) (bin #t '= 100 100) (bin #f '= -200 100) (bin #f '= +nan.0 +nan.0) + (tri-if #t '= (lambda () 3) 3 3 void) + (tri-if #f '= (lambda () 3) 3 1 void) + (tri-if #f '= (lambda () 3) 1 3 void) + (tri-if #f '= (lambda () 1) 3 3 void) (un 3 'add1 2) (un -3 'add1 -4) @@ -247,6 +287,8 @@ (bin -3 '+ 4 -7) (bin (expt 2 30) '+ (expt 2 29) (expt 2 29)) (bin (- (expt 2 31) 2) '+ (sub1 (expt 2 30)) (sub1 (expt 2 30))) + (tri 6 '+ (lambda () 1) 2 3 void) + (tri 13/2 '+ (lambda () 1) 5/2 3 void) (bin 3 '- 7 4) (bin 11 '- 7 -4) @@ -254,6 +296,8 @@ (bin (expt 2 30) '- (expt 2 29) (- (expt 2 29))) (bin (- (expt 2 30)) '- (- (expt 2 29)) (expt 2 29)) (bin (- 2 (expt 2 31)) '- (- 1 (expt 2 30)) (sub1 (expt 2 30))) + (tri 6 '- (lambda () 10) 3 1 void) + (tri 13/2 '- (lambda () 10) 3 1/2 void) (bin 4 '* 1 4) (bin 0 '* 0 4) @@ -265,6 +309,8 @@ (bin (expt 2 30) '* 2 (expt 2 29)) (bin (expt 2 31) '* 2 (expt 2 30)) (bin (- (expt 2 30)) '* 2 (- (expt 2 29))) + (tri 30 '* (lambda () 2) 3 5 void) + (tri 5 '* (lambda () 2) 3 5/6 void) (bin 0 '/ 0 4) (bin 1/4 '/ 1 4) @@ -273,6 +319,8 @@ (bin -4 '/ -16 4) (bin -4 '/ 16 -4) (bin 4 '/ -16 -4) + (tri 3 '/ (lambda () 30) 5 2 void) + (tri 12 '/ (lambda () 30) 5 1/2 void) (bin-int 3 'quotient 10 3) (bin-int -3 'quotient 10 -3) @@ -289,10 +337,16 @@ (bin 3 'min 3 300) (bin -300 'min 3 -300) (bin -400 'min -400 -300) + (tri 5 'min (lambda () 10) 5 20 void) + (tri 5 'min (lambda () 5) 10 20 void) + (tri 5 'min (lambda () 20) 10 5 void) (bin 300 'max 3 300) (bin 3 'max 3 -300) (bin -3 'max -3 -300) + (tri 50 'max (lambda () 10) 50 20 void) + (tri 50 'max (lambda () 50) 10 20 void) + (tri 50 'max (lambda () 20) 10 50 void) (bin-exact 11 'bitwise-and 11 43) (bin-exact 0 'bitwise-and 11 32) @@ -301,18 +355,21 @@ (bin-exact 11 'bitwise-and 11 -1) (bin-exact -11 'bitwise-and -11 -1) (bin-exact (expt 2 50) 'bitwise-and (expt 2 50) (expt 2 50)) + (tri-exact #x10101 'bitwise-and (lambda () #x11111) #x10111 #x110101 void #f) (bin-exact 11 'bitwise-ior 8 3) (bin-exact 11 'bitwise-ior 11 3) (bin-exact -1 'bitwise-ior 11 -1) (bin-exact (sub1 (expt 2 51)) 'bitwise-ior (sub1 (expt 2 50)) (expt 2 50)) (bin-exact (add1 (expt 2 50)) 'bitwise-ior 1 (expt 2 50)) + (tri-exact #x10101 'bitwise-ior (lambda () #x1) #x100 #x10000 void #f) (bin-exact 11 'bitwise-xor 8 3) (bin-exact 8 'bitwise-xor 11 3) (bin-exact -2 'bitwise-xor 1 -1) (bin-exact (sub1 (expt 2 51)) 'bitwise-xor (sub1 (expt 2 50)) (expt 2 50)) (bin-exact (add1 (expt 2 50)) 'bitwise-xor 1 (expt 2 50)) + (tri-exact #x10101 'bitwise-xor (lambda () #x1) #x110 #x10010 void #f) (bin-exact 4 'arithmetic-shift 2 1) (bin-exact 1 'arithmetic-shift 2 -1) @@ -356,6 +413,10 @@ (un-exact 'a 'unbox (box 'a)) (un-exact 3 'vector-length (vector 'a 'b 'c)) + (bin-exact 1.1 'flvector-ref (flvector 1.1 2.2 3.3) 0) + (bin-exact 3.3 'flvector-ref (flvector 1.1 2.2 3.3) 2) + (un-exact 3 'flvector-length (flvector 1.1 2.2 3.3)) + (bin-exact #\a 'string-ref "abc\u2001" 0) (bin-exact #\b 'string-ref "abc\u2001" 1) (bin-exact #\c 'string-ref "abc\u2001" 2) @@ -397,7 +458,8 @@ '(0 1 2))))]) (test-setter make-vector #f 7 'vector-set! vector-set! vector-ref) (test-setter make-bytes 0 7 'bytes-set! bytes-set! bytes-ref) - (test-setter make-string #\a #\7 'string-set! string-set! string-ref)) + (test-setter make-string #\a #\7 'string-set! string-set! string-ref) + (test-setter make-flvector 1.0 7.0 'flvector-set! flvector-set! flvector-ref)) )) diff --git a/collects/tests/mzscheme/package-gen.ss b/collects/tests/mzscheme/package-gen.ss index c2891b18dc..62d5126e2f 100644 --- a/collects/tests/mzscheme/package-gen.ss +++ b/collects/tests/mzscheme/package-gen.ss @@ -59,8 +59,8 @@ (define combo-context-forms (list (lambda (p o) `(begin ,p ,o)) (lambda (p o) `(let () ,p ,o 10)) - (lambda (p o) `(package out1 all-defined ,p ,o)) - (lambda (p o) `(package out2 all-defined (package out1 all-defined ,p ,o))))) + (lambda (p o) `(define-package out1 #:all-defined ,p ,o)) + (lambda (p o) `(define-package out2 #:all-defined (define-package out1 #:all-defined ,p ,o))))) (define all-forms (apply diff --git a/collects/tests/mzscheme/package.ss b/collects/tests/mzscheme/package.ss index b907652e5e..c60a471180 100644 --- a/collects/tests/mzscheme/package.ss +++ b/collects/tests/mzscheme/package.ss @@ -39,6 +39,7 @@ (define (test-pack-seq* forms expr q-expr result) (let ([orig (current-namespace)]) + ;; top level (let ([ns (make-base-namespace)]) (parameterize ([current-namespace ns]) (namespace-attach-module orig 'scheme/package) @@ -48,6 +49,7 @@ (if (fail? expr) (err/rt-test (eval (fail-expr expr)) result) (test result q-expr (eval expr))))) + ;; let (let ([ns (make-base-namespace)]) (parameterize ([current-namespace ns]) (namespace-attach-module orig 'scheme/package) @@ -57,6 +59,21 @@ (if (fail? expr) (err/rt-test (eval e) result) (test result `(let ... ,q-expr) (eval e)))))) + ;; nested let + (let ([ns (make-base-namespace)]) + (parameterize ([current-namespace ns]) + (namespace-attach-module orig 'scheme/package) + (namespace-require '(for-syntax scheme/base)) + (namespace-require 'scheme/package) + (let ([e (let loop ([forms forms]) + (if (null? (cdr forms)) + `(let () (begin . ,forms) ,(fail-expr expr)) + `(let () ,(car forms) + ,(loop (cdr forms)))))]) + (if (fail? expr) + (err/rt-test (eval e) result) + (test result `(let ... ,q-expr) (eval e)))))) + ;; module (let ([ns (make-base-namespace)]) (parameterize ([current-namespace ns]) (namespace-attach-module orig 'scheme/package) diff --git a/collects/tests/mzscheme/parallel.ss b/collects/tests/mzscheme/parallel.ss index 037409ba6a..64a726e2d0 100644 --- a/collects/tests/mzscheme/parallel.ss +++ b/collects/tests/mzscheme/parallel.ss @@ -1,6 +1,4 @@ -do-not-run-me-yet - ;; Runs 3 threads perfoming the test suite simultaneously. Each ;; thread creates a directory sub to run in, so that filesystem ;; tests don't collide. diff --git a/collects/tests/mzscheme/prompt-sfs.ss b/collects/tests/mzscheme/prompt-sfs.ss index a967382bf5..ccc9ede999 100644 --- a/collects/tests/mzscheme/prompt-sfs.ss +++ b/collects/tests/mzscheme/prompt-sfs.ss @@ -1,16 +1,30 @@ #lang scheme +(require scheme/system) #| This test is designed to to check whether meta-continuations are correctly split when a continuation is delimited in the middle of -a meta-continuation other than the current one. In aprticular, +a meta-continuation other than the current one. In particular, the `x' binding is part of the deeper meta-continuation when `ak' is captured, but it is delimited inside the binding, so `x' should not be reated in `ak'. +The test is implemented using `dump-memory-stats' in another mzscheme +process. + |# +(when (equal? #() (current-command-line-arguments)) + (let ([f (find-executable-path (find-system-path 'exec-file) #f)]) + (let ([p (open-output-bytes)]) + (parameterize ([current-error-port p]) + (system* f "-l" "tests/mzscheme/prompt-sfs" "sub")) + (unless (regexp-match? #rx": +1 +" (get-output-bytes p)) + (error "wrong output") + (exit 1)))) + (exit 0)) + (define (make-big-thing) (cons (make-string 100000) (make-will-executor))) (define (show-big-thing say x) (say (string-length (car x)))) diff --git a/collects/tests/mzscheme/stream.ss b/collects/tests/mzscheme/stream.ss index 443166ea84..df6c622d21 100644 --- a/collects/tests/mzscheme/stream.ss +++ b/collects/tests/mzscheme/stream.ss @@ -1,6 +1,8 @@ (printf "Stream Tests (current dir must be startup dir)~n") +(require scheme/system) + (define (log . args) '(begin (apply printf args) @@ -9,13 +11,13 @@ (define cs-prog '(define (copy-stream in out) (lambda () - (let ([s (make-string 4096)]) + (let ([s (make-bytes 4096)]) (let loop () - (let ([l (read-string-avail! s in)]) + (let ([l (read-bytes-avail! s in)]) (log "in: ~a" l) (unless (eof-object? l) (let loop ([p 0][l l]) - (let ([r (write-string-avail s out p (+ p l))]) + (let ([r (write-bytes-avail s out p (+ p l))]) (log "out: ~a" r) (when (< r l) (loop (+ p r) (- l r))))) @@ -29,9 +31,9 @@ (define (feed-file out) (let ([p (open-input-file test-file)]) (let loop () - (let ([c (read-char p)]) + (let ([c (read-byte p)]) (unless (eof-object? c) - (write-char c out) + (write-byte c out) (loop)))))) (define (feed-file/fast out) @@ -42,15 +44,15 @@ (define (check-file in) (let ([p (open-input-file test-file)]) (let loop ([badc 0]) - (let ([c (read-char p)] - [c2 (read-char in)]) + (let ([c (read-byte p)] + [c2 (read-byte in)]) (unless (eq? c c2) (if (= badc 30) (error "check-failed" (file-position p) c c2) (begin (fprintf (current-error-port) - "fail: ~a ~s ~s~n" - (file-position p) c c2) + "fail: ~a ~s=~s ~s=~s~n" + (file-position p) c (integer->char c) c2 (integer->char c2)) (loop (add1 badc))))) (unless (eof-object? c) (loop badc)))) @@ -59,8 +61,8 @@ (define (check-file/fast in) (let ([p (open-input-file test-file)]) (let loop () - (let* ([s (read-string 5000 p)] - [s2 (read-string (if (string? s) (string-length s) 100) in)]) + (let* ([s (read-bytes 5000 p)] + [s2 (read-bytes (if (bytes? s) (bytes-length s) 100) in)]) (unless (equal? s s2) (error "fast check failed")) (unless (eof-object? s) @@ -69,23 +71,23 @@ (define (check-file/fastest in) (let ([p (open-input-file test-file)] - [s1 (make-string 5000)] - [s2 (make-string 5000)]) + [s1 (make-bytes 5000)] + [s2 (make-bytes 5000)]) (let loop ([leftover 0][startpos 0][pos 0]) (let* ([n1 (if (zero? leftover) - (read-string-avail! s1 p) + (read-bytes-avail! s1 p) leftover)] - [n2 (read-string-avail! s2 in 0 (if (eof-object? n1) - 1 + [n2 (read-bytes-avail! s2 in 0 (if (eof-object? n1) + 1 n1))]) (unless (if (or (eof-object? n1) (eof-object? n2)) (and (eof-object? n1) (eof-object? n2)) (if (= n2 n1 5000) - (string=? s1 s2) - (string=? (substring s1 startpos (+ startpos n2)) - (substring s2 0 n2)))) + (bytes=? s1 s2) + (bytes=? (subbytes s1 startpos (+ startpos n2)) + (subbytes s2 0 n2)))) (error 'check "failed at ~a (~a@~a ~a)" pos n1 startpos n2)) (unless (eof-object? n1) (loop (- n1 n2) @@ -95,11 +97,11 @@ (+ pos n2))))) (close-input-port p))) -(define portno 40000) +(define portno 40010) (define (setup-mzscheme-echo tcp?) (define p (process* test-file "-q" "-b")) - (define s (make-string 256)) + (define s (make-bytes 256)) (define r #f) (define w #f) (define r2 #f) @@ -118,18 +120,18 @@ (set! w2 ww2)))]) (fprintf (cadr p) "(define-values (r w) (tcp-connect \"localhost\" ~a))~n" portno) (fprintf (cadr p) "(define-values (r2 w2) (tcp-connect \"localhost\" ~a))~n" (add1 portno)) + (flush-output (cadr p)) (thread-wait t) (fprintf (cadr p) "(begin ((copy-stream r w2)) (exit))~n")) - (fprintf (cadr p) "(begin ((copy-stream (current-input-port) (current-output-port))) (exit))~n")) + (fprintf (cadr p) "(begin (flush-output) ((copy-stream (current-input-port) (current-output-port))) (exit))~n")) + (flush-output (cadr p)) - ;; Flush initial output: - (read-string (string-length (banner)) (car p)) - (sleep 0.3) - (when (char-ready? (car p)) - (read-string-avail! s (car p))) - (sleep 0.3) - (when (char-ready? (car p)) - (read-string-avail! s (car p))) + (unless tcp? + ;; Flush initial output from other process: + (let loop () + (sleep 0.3) + (unless (zero? (read-bytes-avail!* s (car p))) + (loop)))) (if tcp? (values r w r2 w2) @@ -218,7 +220,7 @@ (start "To file and back:~n") (start " to...~n") (define-values (r w) (make-pipe)) -(define p (open-output-file tmp-file 'truncate)) +(define p (open-output-file tmp-file #:exists 'truncate)) (define t (thread (copy-stream r p))) (feed-file w) (close-output-port w) @@ -239,7 +241,7 @@ (start "To file and back, faster:~n") (start " to...~n") (define-values (r w) (make-pipe)) -(define p (open-output-file tmp-file 'truncate)) +(define p (open-output-file tmp-file #:exists 'truncate)) (define t (thread (copy-stream r p))) (feed-file/fast w) (close-output-port w) @@ -295,8 +297,8 @@ (check-file/fast rp2) (end) -(define l1 (tcp-listen portno)) -(define l2 (tcp-listen (add1 portno))) +(define l1 (tcp-listen portno 5 #t)) +(define l2 (tcp-listen (add1 portno) 5 #t)) (start "TCP Echo...~n") (define-values (r w r2 w2) (setup-mzscheme-echo #t)) diff --git a/collects/tests/mzscheme/stx.ss b/collects/tests/mzscheme/stx.ss index 61f836f999..468401b84d 100644 --- a/collects/tests/mzscheme/stx.ss +++ b/collects/tests/mzscheme/stx.ss @@ -72,41 +72,46 @@ (test 'yes 'dot-literal (syntax-case #'(1 . #t) () [(_ . #t) 'yes] [_ 'no])) (test '(((x 3) (y 3) (z 3)) ;; each line should be x y z, not x x x... - ((x 4) (y 4) (z 4)) - ((x 5) (y 5) (z 5))) + ((x 4) (y 4) (z 4)) + ((x 5) (y 5) (z 5))) 'ellipses - (syntax->datum (syntax-case '(_ 1 (x y z) ((3 3 3) (4 4 4) (5 5 5))) () - [(_ x (a ...) ((b ...) ...)) #'(((a b) ...) ...)]))) + (syntax->datum (syntax-case '(_ 1 (x y z) ((3 3 3) (4 4 4) (5 5 5))) () + [(_ x (a ...) ((b ...) ...)) #'(((a b) ...) ...)]))) (test '(((x y z 3) (x y z 3) (x y z 3)) - ((x y z 4) (x y z 4) (x y z 4)) - ((x y z 5) (x y z 5) (x y z 5))) + ((x y z 4) (x y z 4) (x y z 4)) + ((x y z 5) (x y z 5) (x y z 5))) 'ellipses - (syntax->datum (syntax-case '(_ 1 (x y z) ((3 3 3) (4 4 4) (5 5 5))) () - [(_ x (a ...) ((b ...) ...)) #'(((a ... b) ...) ...)]))) + (syntax->datum (syntax-case '(_ 1 (x y z) ((3 3 3) (4 4 4) (5 5 5))) () + [(_ x (a ...) ((b ...) ...)) #'(((a ... b) ...) ...)]))) (test '((1 z) (2 w) (x z) (y w)) 'ellipses - (syntax->datum (syntax-case '(((1 2) (x y)) (z w)) () - [(((a ...) ...) (b ...)) #'((a b) ... ...)]))) + (syntax->datum (syntax-case '(((1 2) (x y)) (z w)) () + [(((a ...) ...) (b ...)) #'((a b) ... ...)]))) (test '(#(1) #(2 3)) 'ellipses+vector - (syntax->datum - (syntax-case '((1) (2 3)) () [((a ...) ...) #'(#(a ...) ...)]))) + (syntax->datum + (syntax-case '((1) (2 3)) () + [((a ...) ...) #'(#(a ...) ...)]))) (test '(1 2 3 6 8 9 0 1 2 3) - syntax->datum - (syntax-case '(((1) (2 3)) ((6)) ((8 9 0) (1 2 3))) () [(((a ...) ...) ...) #'(a ... ... ...)])) + syntax->datum + (syntax-case '(((1) (2 3)) ((6)) ((8 9 0) (1 2 3))) () + [(((a ...) ...) ...) #'(a ... ... ...)])) (test '((1 2 3) (6) (8 9 0 1 2 3)) - syntax->datum - (syntax-case '(((1) (2 3)) ((6)) ((8 9 0) (1 2 3))) () [(((a ...) ...) ...) #'((a ... ...) ...)])) + syntax->datum + (syntax-case '(((1) (2 3)) ((6)) ((8 9 0) (1 2 3))) () + [(((a ...) ...) ...) #'((a ... ...) ...)])) (test '((1) (2 3) (6) (8 9 0) (1 2 3)) - syntax->datum - (syntax-case '(((1) (2 3)) ((6)) ((8 9 0) (1 2 3))) () [(((a ...) ...) ...) #'((a ...) ... ...)])) + syntax->datum + (syntax-case '(((1) (2 3)) ((6)) ((8 9 0) (1 2 3))) () + [(((a ...) ...) ...) #'((a ...) ... ...)])) -(test (syntax-case #'((([n 1] [m 2]) ([p 10] [q 20])) (([nn -1] [mm -2]) ([pp -10] [qq -20]))) () +(test (syntax-case #'((([n 1] [m 2]) ([p 10] [q 20])) + (([nn -1] [mm -2]) ([pp -10] [qq -20]))) () [((([x y] ...) ...) ...) (syntax->datum #'(ell ((ull (+ x ...) ((- x ... y ...) ...)) @@ -118,7 +123,8 @@ ((ull (+ nn mm) ((- n m 1 2) (- p q 10 20))) (ull (+ pp qq) ((- nn mm -1 -2) (- pp qq -10 -20)))))) -(test (syntax-case #'((([n 1] [m 2]) ([p 10] [q 20])) (([nn -1] [mm -2]) ([pp -10] [qq -20]))) () +(test (syntax-case #'((([n 1] [m 2]) ([p 10] [q 20])) + (([nn -1] [mm -2]) ([pp -10] [qq -20]))) () [((([x y] ...) ...) ...) (syntax->datum #'(ell ((ull (+ x ...) ((- x ...) ...)) @@ -137,11 +143,11 @@ (define (tree-map f) (lambda (l) (if (pair? l) - (cons ((tree-map f) (car l)) - ((tree-map f) (cdr l))) - (if (null? l) - null - (f l))))) + (cons ((tree-map f) (car l)) + ((tree-map f) (cdr l))) + (if (null? l) + null + (f l))))) (define-syntax mcr (lambda (stx) @@ -154,7 +160,7 @@ (syntax-case se () [(bg five) (let ([bg (syntax bg)] - [five (syntax five)]) + [five (syntax five)]) (test 'begin syntax-e bg) (test 5 syntax-e five) @@ -203,11 +209,11 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Constructed s, se is part of s, part of s tagged -(define s (syntax-property (with-syntax ([five (syntax-property (quote-syntax 5) - 'testing - 12)]) - (syntax (mcr2 five))) - 'testing 10)) +(define s + (syntax-property + (with-syntax ([five (syntax-property (quote-syntax 5) 'testing 12)]) + (syntax (mcr2 five))) + 'testing 10)) (define se (expand-once s)) (test (syntax-e (cadr (syntax-e s))) syntax-e se) @@ -223,14 +229,14 @@ ;; paren-shape: (let ([s (with-syntax ([a (quote-syntax [x y])]) - #'[a 10])]) + #'[a 10])]) (test #f syntax-property #'(x) 'paren-shape) (test #\[ syntax-property #'[x] 'paren-shape) (test #\[ syntax-property s 'paren-shape) (test #\[ syntax-property (syntax-case s () [(b _) #'b]) 'paren-shape)) (let ([s (with-syntax ([(a ...) '(1 2 3)]) - #'[a ...])]) + #'[a ...])]) (test #\[ syntax-property s 'paren-shape)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -317,16 +323,17 @@ ;; Symbol Keys (test null syntax-property-symbol-keys #'a) (let ([ssort (lambda (l) - (if (equal? l '(yep aha)) - '(aha yep) - l))]) + (if (equal? l '(yep aha)) + '(aha yep) + l))]) (test '(aha) syntax-property-symbol-keys (syntax-property #'a 'aha 1)) (test '(aha yep) ssort (syntax-property-symbol-keys (syntax-property (syntax-property #'a 'aha 1) 'yep 2))) - (test '(aha yep) ssort (syntax-property-symbol-keys (syntax-property - (syntax-property - (syntax-property #'a 'aha 1) - 'yep 2) - 'aha 3)))) + (test '(aha yep) ssort (syntax-property-symbol-keys + (syntax-property + (syntax-property + (syntax-property #'a 'aha 1) + 'yep 2) + 'aha 3)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Test free-identifier=? on different phases via syntax-case* @@ -349,15 +356,15 @@ (define-syntax ck (lambda (stx) (syntax-case stx () - [(_ id et?) - (with-syntax ([cmp (if (syntax-e (syntax et?)) - (syntax free-transformer-identifier=?) - (syntax free-identifier=?))]) - (syntax - (lambda (x) - (syntax-case* x (id) cmp - [(_ id) #t] - [else #f]))))]))) + [(_ id et?) + (with-syntax ([cmp (if (syntax-e (syntax et?)) + (syntax free-transformer-identifier=?) + (syntax free-identifier=?))]) + (syntax + (lambda (x) + (syntax-case* x (id) cmp + [(_ id) #t] + [else #f]))))]))) (define has-lam? (ck case-lambda #f)) (define has-mz:lam? (ck mz:case-lambda #f)) @@ -370,7 +377,7 @@ (define has-et-mtby? (ck b:mtby #t)) (provide has-lam? has-mz:lam? has-mtax? has-mtby? - has-et-lam? has-et-mz:lam? has-et-mtax? has-et-mtby?)) + has-et-lam? has-et-mz:lam? has-et-mtax? has-et-mtby?)) (require 'mt1) (require (for-syntax 'mtb)) @@ -410,13 +417,13 @@ (datum->syntax stx (cons - (quote-syntax quote-syntax) - (cdr (syntax-e stx))) + (quote-syntax quote-syntax) + (cdr (syntax-e stx))) stx))) (define-values (run-mt2-test) (lambda (test) - + (test #t has-lam? #'(any case-lambda)) (test #f has-lam? #'(any case-lambada)) @@ -462,6 +469,7 @@ (let ([b (identifier-binding s)]) (if (list? b) (list* (let-values ([(name base) (module-path-index-split (car b))]) + (fprintf (current-error-port) ">>>>base = ~s\n" base) name) (cadr b) (let-values ([(name base) (module-path-index-split (caddr b))]) @@ -469,34 +477,40 @@ (cdddr b)) b))) -(test '('#%kernel case-lambda (lib "scheme/init") case-lambda 0 0 0) identifier-binding* #'case-lambda) -(test '(scheme/promise delay* (lib "scheme/init") delay 0 0 0) identifier-binding* #'delay) -(test '('#%kernel #%module-begin (lib "scheme/init") #%plain-module-begin 0 0 0) identifier-binding* #'#%plain-module-begin) +(test '('#%kernel case-lambda (lib "scheme/init") case-lambda 0 0 0) + identifier-binding* #'case-lambda) +(test '("private/promise.ss" delay* (lib "scheme/init") delay 0 0 0) + identifier-binding* #'delay) +(test '('#%kernel #%module-begin (lib "scheme/init") #%plain-module-begin 0 0 0) + identifier-binding* #'#%plain-module-begin) (require (only-in scheme/base [#%plain-module-begin #%pmb])) -(test '('#%kernel #%module-begin scheme/base #%plain-module-begin 0 0 0) identifier-binding* #'#%pmb) +(test '('#%kernel #%module-begin scheme/base #%plain-module-begin 0 0 0) + identifier-binding* #'#%pmb) -(let ([b (identifier-binding (syntax-case (expand #'(module m scheme/base - (require (only-in (lib "lang/htdp-intermediate.ss") [cons bcons])) - bcons)) () - [(mod m mz (#%mod-beg req (app call-with-values (lambda () cons) print))) - (let ([s (syntax cons)]) - (test 'bcons syntax-e s) - s)]))]) +(let ([b (identifier-binding + (syntax-case (expand #'(module m scheme/base + (require (only-in (lib "lang/htdp-intermediate.ss") [cons bcons])) + bcons)) () + [(mod m mz (#%mod-beg req (app call-with-values (lambda () cons) print))) + (let ([s (syntax cons)]) + (test 'bcons syntax-e s) + s)]))]) (let-values ([(real real-base) (module-path-index-split (car b))] - [(nominal nominal-base) (module-path-index-split (caddr b))]) + [(nominal nominal-base) (module-path-index-split (caddr b))]) (test '"teachprims.ss" values real) (test 'beginner-cons cadr b) (test '(lib "lang/htdp-intermediate.ss") values nominal) (test 'cons cadddr b))) -(let ([b (identifier-binding (syntax-case (expand #'(module m (lib "lang/htdp-intermediate.ss") - cons)) () - [(mod m beg (#%mod-beg (app call-w-vals (lam () cons) prnt))) - (let ([s (syntax cons)]) - (test 'cons syntax-e s) - s)]))]) +(let ([b (identifier-binding + (syntax-case (expand #'(module m (lib "lang/htdp-intermediate.ss") + cons)) () + [(mod m beg (#%mod-beg (app call-w-vals (lam () cons) prnt))) + (let ([s (syntax cons)]) + (test 'cons syntax-e s) + s)]))]) (let-values ([(real real-base) (module-path-index-split (car b))] - [(nominal nominal-base) (module-path-index-split (caddr b))]) + [(nominal nominal-base) (module-path-index-split (caddr b))]) (test '"teachprims.ss" values real) (test 'beginner-cons cadr b) (test '(lib "lang/htdp-intermediate.ss") values nominal) @@ -516,18 +530,18 @@ (err/rt-test (eval-syntax 'eval)) (err/rt-test (eval-syntax eval)) (test eval eval-syntax #'eval) - (test #t - 'eval-syntax - (with-handlers ([exn:fail:syntax? (lambda (x) #t)]) - (eval-syntax (datum->syntax #f 'eval)))) + (test #t + 'eval-syntax + (with-handlers ([exn:fail:syntax? (lambda (x) #t)]) + (eval-syntax (datum->syntax #f 'eval)))) (test eval (current-eval) 'eval) (test eval (current-eval) eval) (test eval (current-eval) #'eval) - (test #t - 'current-eval-syntax - (with-handlers ([exn:fail:syntax? (lambda (x) #t)]) - ((current-eval) (datum->syntax #f 'eval)))) + (test #t + 'current-eval-syntax + (with-handlers ([exn:fail:syntax? (lambda (x) #t)]) + ((current-eval) (datum->syntax #f 'eval)))) (test eval 'compile (eval (compile 'eval))) (test eval 'compile (eval (compile eval))) @@ -537,10 +551,10 @@ (err/rt-test (compile-syntax 'eval)) (err/rt-test (compile-syntax eval)) (test eval 'compile (eval (compile-syntax #'eval))) - (test #t - 'compile-syntax - (with-handlers ([exn:fail:syntax? (lambda (x) #t)]) - (compile-syntax (datum->syntax #f 'eval)))) + (test #t + 'compile-syntax + (with-handlers ([exn:fail:syntax? (lambda (x) #t)]) + (compile-syntax (datum->syntax #f 'eval)))) (test eval 'expand (eval (expand 'eval))) (test eval 'expand (eval (expand eval))) @@ -550,10 +564,10 @@ (err/rt-test (expand-syntax 'eval)) (err/rt-test (expand-syntax eval)) (test eval 'expand (eval (expand-syntax #'eval))) - (test #t - 'expand-syntax - (with-handlers ([exn:fail:syntax? (lambda (x) #t)]) - (expand-syntax (datum->syntax #f 'eval)))) + (test #t + 'expand-syntax + (with-handlers ([exn:fail:syntax? (lambda (x) #t)]) + (expand-syntax (datum->syntax #f 'eval)))) (test eval 'expand-once (eval (expand-once 'eval))) (test eval 'expand-once (eval (expand-once eval))) @@ -563,10 +577,10 @@ (err/rt-test (expand-syntax-once 'eval)) (err/rt-test (expand-syntax-once eval)) (test eval 'expand-once (eval (expand-syntax-once #'eval))) - (test #t - 'expand-syntax-once - (with-handlers ([exn:fail:syntax? (lambda (x) #t)]) - (expand-syntax-once (datum->syntax #f 'eval)))) + (test #t + 'expand-syntax-once + (with-handlers ([exn:fail:syntax? (lambda (x) #t)]) + (expand-syntax-once (datum->syntax #f 'eval)))) (test eval 'expand-to-top-form (eval (expand-to-top-form 'eval))) (test eval 'expand-to-top-form (eval (expand-to-top-form eval))) @@ -591,58 +605,58 @@ (define (has-p? stx) (let ([p (syntax-property stx prop)]) (and p - (let loop ([p p]) - (cond - [(pair? p) (or (loop (car p)) - (loop (cdr p)))] - [else (and (identifier? p) + (let loop ([p p]) + (cond + [(pair? p) (or (loop (car p)) + (loop (cdr p)))] + [else (and (identifier? p) (eq? what (syntax-e p)))]))))) - + (let loop ([stx stx]) (or (and (has-p? stx) - (or (eq? #t where) - (eq? (syntax-e stx) where) - (and (pair? (syntax-e stx)) - (eq? (syntax-e (car (syntax-e stx))) - where)))) - (syntax-case stx (#%plain-lambda case-lambda begin begin0 + (or (eq? #t where) + (eq? (syntax-e stx) where) + (and (pair? (syntax-e stx)) + (eq? (syntax-e (car (syntax-e stx))) + where)))) + (syntax-case stx (#%plain-lambda case-lambda begin begin0 set! with-continuation-mark if #%plain-app module #%plain-module-begin define-values) - [(#%plain-lambda formals expr ...) - (ormap loop (syntax->list #'(expr ...)))] - [(case-lambda [formals expr ...] ...) - (ormap (lambda (l) - (ormap loop (syntax->list l))) - (syntax->list #'((expr ...) ...)))] - [(let ([(id ...) rhs] ...) expr ...) - (or (free-identifier=? #'let #'let-values) - (free-identifier=? #'let #'letrec-values)) - (or (and (boolean? where) - (syntax-case stx () - [(let [clause ...] expr) - (ormap has-p? (syntax->list #'(clause ...)))])) - (ormap loop (syntax->list #'(expr ...))) - (ormap loop (syntax->list #'(rhs ...))))] - [(begin expr ...) - (ormap loop (syntax->list #'(expr ...)))] - [(begin0 expr ...) - (ormap loop (syntax->list #'(expr ...)))] - [(set! id expr) - (loop #'expr)] - [(with-continuation-mark key val expr) - (or (loop #'key) (loop #'val) (loop #'expr))] - [(if test then else) - (or (loop #'test) (loop #'then) (loop #'else))] - [(#%plain-app expr ...) - (ormap loop (syntax->list #'(expr ...)))] - [(module name init body) - (loop #'body)] - [(#%plain-module-begin expr ...) - (ormap loop (syntax->list #'(expr ...)))] - [(define-values (id ...) expr) - (loop #'expr)] - [_ #f])))) + [(#%plain-lambda formals expr ...) + (ormap loop (syntax->list #'(expr ...)))] + [(case-lambda [formals expr ...] ...) + (ormap (lambda (l) + (ormap loop (syntax->list l))) + (syntax->list #'((expr ...) ...)))] + [(let ([(id ...) rhs] ...) expr ...) + (or (free-identifier=? #'let #'let-values) + (free-identifier=? #'let #'letrec-values)) + (or (and (boolean? where) + (syntax-case stx () + [(let [clause ...] expr) + (ormap has-p? (syntax->list #'(clause ...)))])) + (ormap loop (syntax->list #'(expr ...))) + (ormap loop (syntax->list #'(rhs ...))))] + [(begin expr ...) + (ormap loop (syntax->list #'(expr ...)))] + [(begin0 expr ...) + (ormap loop (syntax->list #'(expr ...)))] + [(set! id expr) + (loop #'expr)] + [(with-continuation-mark key val expr) + (or (loop #'key) (loop #'val) (loop #'expr))] + [(if test then else) + (or (loop #'test) (loop #'then) (loop #'else))] + [(#%plain-app expr ...) + (ormap loop (syntax->list #'(expr ...)))] + [(module name init body) + (loop #'body)] + [(#%plain-module-begin expr ...) + (ormap loop (syntax->list #'(expr ...)))] + [(define-values (id ...) expr) + (loop #'expr)] + [_ #f])))) (test #t has-stx-property? (expand #'(let ([x 1]) 2)) 'let-values 'let 'origin) @@ -652,7 +666,7 @@ (test #t has-stx-property? (expand #'(module m scheme/base (define-struct x (a)))) 'define-syntaxes 'define-struct 'origin) ;; The s macro also expands to begin: -(test #t has-stx-property? (expand #'(module m scheme/base +(test #t has-stx-property? (expand #'(module m scheme/base (require (for-syntax scheme/base)) (define-syntax (s stx) #'(begin @@ -660,7 +674,7 @@ 14)) s)) '#%app 's 'origin) -(test #t has-stx-property? (expand #'(module m scheme/base +(test #t has-stx-property? (expand #'(module m scheme/base (require (for-syntax scheme/base)) (define-syntax (s stx) #'(begin @@ -688,10 +702,10 @@ (test #t has-stx-property? (expand #'(let () (define-syntax (x stx) #'(quote y)) x)) 'quote 'x 'origin) (let ([check-expr (lambda (expr) - (let ([e (expand expr)]) - (syntax-case e () - [(lv (bind ...) beg) - (let ([db (syntax-property #'beg 'disappeared-binding)]) + (let ([e (expand expr)]) + (syntax-case e () + [(lv (bind ...) beg) + (let ([db (syntax-property #'beg 'disappeared-binding)]) (let-values ([(bg e) (syntax-case #'beg (#%plain-app list) [(bg () (#%plain-app list e)) @@ -731,12 +745,12 @@ (module ++q scheme/base (require (for-syntax '++p scheme/base)) - (define ++d 11) + (define ++d 11) (define-syntax (++o stx) #'++d) (define-syntax (++s stx) (syntax-case stx () - [(_ id) #'(define-syntax (id stx) - (datum->syntax #'here (++goo)))])) + [(_ id) #'(define-syntax (id stx) + (datum->syntax #'here (++goo)))])) (define-syntax (++t stx) (syntax-case stx () [(_ id) #'(define-values (id) ++d)])) (define-syntax (++t2 stx) #'(begin ++d)) (define-syntax (++t3 stx) (syntax-property #'(begin0 ++d) 'certify-mode 'transparent)) @@ -749,14 +763,14 @@ (syntax-case stx () [(_ id) (datum->syntax #'here (add1 (syntax-local-value #'id)))])) (define-syntax (++o2 stx) #'(++check-val ++ds)) - (define-syntax (++apply-to-ds stx) + (define-syntax (++apply-to-ds stx) (syntax-case stx () [(_ id) #'(id ++ds)])) - (define-syntax (++apply-to-d stx) + (define-syntax (++apply-to-d stx) (syntax-case stx () [(_ id) #'(id ++d)])) (provide ++o ++o2 ++s ++t ++t2 ++t3 ++t4 ++v ++v2 ++v3 - ++apply-to-d ++apply-to-ds)) + ++apply-to-d ++apply-to-ds)) (require '++q) (++s ++ack) @@ -767,31 +781,31 @@ (test 13 values (let () (++t id) 13)) (let-syntax ([goo (lambda (stx) - (syntax-case stx () - [(_ id) (datum->syntax #'here (sub1 (syntax-local-value #'id)))]))]) + (syntax-case stx () + [(_ id) (datum->syntax #'here (sub1 (syntax-local-value #'id)))]))]) (test 16 'goo (++apply-to-ds goo))) (unless building-flat-tests? (test 11 eval-syntax (expand-syntax #'++o)) (test 11 eval-syntax (syntax-case (expand-syntax #'++t2) () - [(_ x) #'x])) + [(_ x) #'x])) (test 11 eval-syntax (syntax-case (expand #'(++t z)) () - [(d-v (_) x) #'x])) + [(d-v (_) x) #'x])) (test 11 eval-syntax (syntax-case (expand-syntax #'++t3) () - [(_ x) #'x])) + [(_ x) #'x])) (test 11 eval-syntax (syntax-case (expand #'(++t4 z)) () - [(d-v (_) x) #'x])) + [(d-v (_) x) #'x])) (err/rt-test (teval (syntax-case (expand #'++v) () - [(_ x) #'x])) - exn:fail:syntax?) + [(_ x) #'x])) + exn:fail:syntax?) (err/rt-test (teval (syntax-case (expand #'++v2) () - [(_ x) #'x])) - exn:fail:syntax?) + [(_ x) #'x])) + exn:fail:syntax?) (err/rt-test (teval (syntax-case (expand #'++v3) () - [(_ x) #'x])) - exn:fail:syntax?)) + [(_ x) #'x])) + exn:fail:syntax?)) (let ([expr (expand-syntax #'++v)]) (test expr syntax-recertify expr expr (current-inspector) #f) @@ -799,50 +813,50 @@ (test #t syntax? new) (test 'no-marks syntax-e new)) (test #t syntax? (syntax-recertify (syntax-case expr () - [(beg id) #'beg]) - expr (current-inspector) #f)) + [(beg id) #'beg]) + expr (current-inspector) #f)) ;; we'd prefer this to fail, but it's defined to succeed: (test #t syntax? (syntax-recertify (syntax-case expr () - [(beg id) #'id]) - expr (current-inspector) #f)) + [(beg id) #'id]) + expr (current-inspector) #f)) (test #t syntax? (syntax-recertify (datum->syntax expr (syntax-e expr)) - expr (current-inspector) #f)) + expr (current-inspector) #f)) ;; we'd prefer this to fail, but it's defined to succeed: (test #t syntax? (syntax-recertify (syntax-case expr () - [(beg id) #'(ack id)]) - expr (current-inspector) #f))) + [(beg id) #'(ack id)]) + expr (current-inspector) #f))) (let ([expr (expand-syntax #'(++apply-to-d ack))]) (test '(#%app (#%top . ack) ++d) syntax->datum expr) (let ([try (lambda (cvt? other) - (syntax-recertify (datum->syntax - expr - (cons (car (syntax-e expr)) - ((if cvt? - (lambda (x) (datum->syntax - (cdr (syntax-e expr)) - x)) - values) - (cons - other - (cdr (syntax-e (cdr (syntax-e expr)))))))) - expr - (current-inspector) - #f))]) + (syntax-recertify (datum->syntax + expr + (cons (car (syntax-e expr)) + ((if cvt? + (lambda (x) (datum->syntax + (cdr (syntax-e expr)) + x)) + values) + (cons + other + (cdr (syntax-e (cdr (syntax-e expr)))))))) + expr + (current-inspector) + #f))]) (test #t syntax? (try #f #'other!)) (let ([new (try #t #'other!)]) (test #t syntax? new) (test '(#%app other! ++d) syntax->datum new)) ;; we'd prefer this to fail, but it's defined to succeed: (test #t syntax? (try #t (syntax-case expr () - [(ap _ d) #'d]))))) + [(ap _ d) #'d]))))) + - ;; ---------------------------------------- (module ++m scheme/base (require (for-syntax scheme/base)) - (define ++x 10) + (define ++x 10) (define-syntax (++xm stx) #'100) (provide (protect-out ++x ++xm))) (module ++n scheme/base @@ -878,7 +892,7 @@ (namespace-attach-module n ''++n)) (parameterize ([current-code-inspector i] - [current-namespace n2]) + [current-namespace n2]) (namespace-require 'scheme/base) (teval '(require '++n)) @@ -895,22 +909,22 @@ (err/rt-test (teval '++x) exn:fail:syntax?) (err/rt-test (teval '++xm) exn:fail:syntax?) (err/rt-test (teval '++y-macro2) exn:fail:syntax?) - + (teval '(module zrt scheme/base - (require '++n) - (define (vy) ++y) - (define (vy2) ++y-macro) - (define (vu) ++u-macro) - (define (vu2) ++u2) - (provide vy vy2 vu vu2))) + (require '++n) + (define (vy) ++y) + (define (vy2) ++y-macro) + (define (vu) ++u-macro) + (define (vu2) ++u2) + (provide vy vy2 vu vu2))) (teval '(module zct scheme/base (require (for-syntax scheme/base '++n)) - (define-syntax (wy stx) (datum->syntax #'here ++y)) - (let-syntax ([goo ++y-macro]) 10) - (define-syntax (wy2 stx) (datum->syntax #'here ++y-macro)) - (define-syntax (wu stx) (datum->syntax #'here ++u-macro)) - (provide wy wy2 wu))) + (define-syntax (wy stx) (datum->syntax #'here ++y)) + (let-syntax ([goo ++y-macro]) 10) + (define-syntax (wy2 stx) (datum->syntax #'here ++y-macro)) + (define-syntax (wu stx) (datum->syntax #'here ++u-macro)) + (provide wy wy2 wu))) (teval '(require 'zct)) @@ -924,14 +938,14 @@ (test 10 teval '(vy2)) (test 8 teval '(vu)) (test 8 teval '(vu2))) - + (let ([old-insp (current-code-inspector)]) (parameterize ([current-code-inspector i] - [current-namespace n2]) + [current-namespace n2]) (namespace-unprotect-module old-insp ''++m))) (parameterize ([current-code-inspector i] - [current-namespace n2]) + [current-namespace n2]) (test 10 teval '++y-macro) (test 10 teval '++y-macro2))) @@ -953,7 +967,7 @@ (syntax-rules () [(_ get-foo) (define-syntax (get-foo stx) - (syntax-local-value #'foo))]))) + (syntax-local-value #'foo))]))) (require '++//n) (++//def ++//get-foo) (test 17 values ++//get-foo) @@ -966,12 +980,12 @@ (syntax-case stx () [(_ n) (if (zero? (syntax-e #'n)) - #'(list #f 0) - (with-syntax ([m (sub1 (syntax-e #'n))]) + #'(list #f 0) + (with-syntax ([m (sub1 (syntax-e #'n))]) #`(list '#,(syntax-local-lift-context) #,(syntax-local-lift-expression #'(add1 (cadr (@@foo m)))))))])) -(define lifted-output #f) +(define lifted-output #f) (define-syntax (@@goo stx) (syntax-case stx () @@ -999,9 +1013,9 @@ (syntax-case stx () [(_ n) (if (zero? (syntax-e #'n)) - #'0 - (with-syntax ([m (sub1 (syntax-e #'n))]) - (syntax-local-lift-expression #'(add1 (@@foo m)))))])) + #'0 + (with-syntax ([m (sub1 (syntax-e #'n))]) + (syntax-local-lift-expression #'(add1 (@@foo m)))))])) (define-syntax (@@foox stx) (syntax-case stx () [(_ n) @@ -1024,7 +1038,7 @@ (test 3 'ls-foo (let-syntax ([z (lambda (stx) #`#,(@@foo 3))]) - z)) + z)) (test (void) eval (expand #'(begin-for-syntax (define @@zoo (@@foo 2))))) (define-syntax (@@x stx) #`#, @@zoo) @@ -1052,8 +1066,8 @@ (syntax-case stx () [(_ n) (if (zero? (syntax-e #'n)) - #'(list #f 0) - (with-syntax ([m (sub1 (syntax-e #'n))]) + #'(list #f 0) + (with-syntax ([m (sub1 (syntax-e #'n))]) (let ([prev prev-ctx]) (if prev (unless (eq? prev (syntax-local-lift-context)) @@ -1107,45 +1121,45 @@ (let ([go-once (lambda (eval) - (parameterize ([current-namespace (make-base-namespace)]) - (eval '(module mm scheme/base + (parameterize ([current-namespace (make-base-namespace)]) + (eval '(module mm scheme/base (require (for-syntax scheme/base)) - (define-syntax (define$ stx) - (syntax-case stx () - [(_ id val) - (with-syntax ([x (datum->syntax #f 'x)]) - #'(begin - (define x val) - (define-syntax (id stx) #'x)))])) - (define$ a 1) - (define$ b 2) - (printf "~a ~a~n" a b))) - (eval '(require 'mm)) - (eval '(current-namespace (module->namespace ''mm))) + (define-syntax (define$ stx) + (syntax-case stx () + [(_ id val) + (with-syntax ([x (datum->syntax #f 'x)]) + #'(begin + (define x val) + (define-syntax (id stx) #'x)))])) + (define$ a 1) + (define$ b 2) + (printf "~a ~a~n" a b))) + (eval '(require 'mm)) + (eval '(current-namespace (module->namespace ''mm))) - (eval '(define$ c 7)) - (test '(1 2 7) eval '(list a b c)) - (eval '(define$ d 8)) - (test '(1 2 7 8) eval '(list a b c d))) + (eval '(define$ c 7)) + (test '(1 2 7) eval '(list a b c)) + (eval '(define$ d 8)) + (test '(1 2 7 8) eval '(list a b c d))) - (parameterize ([current-namespace (make-base-namespace)]) - (eval '(module mm scheme/base + (parameterize ([current-namespace (make-base-namespace)]) + (eval '(module mm scheme/base (require (for-syntax scheme/base)) - (define-syntax (define$ stx) - (syntax-case stx () - [(_ id val) - (with-syntax ([x (syntax-local-lift-expression #'val)]) - #'(define-syntax (id stx) #'x))])) - (define$ a 1) - (define$ b 2) - (printf "~a ~a~n" a b))) - (eval '(require 'mm)) - (eval '(current-namespace (module->namespace ''mm))) + (define-syntax (define$ stx) + (syntax-case stx () + [(_ id val) + (with-syntax ([x (syntax-local-lift-expression #'val)]) + #'(define-syntax (id stx) #'x))])) + (define$ a 1) + (define$ b 2) + (printf "~a ~a~n" a b))) + (eval '(require 'mm)) + (eval '(current-namespace (module->namespace ''mm))) - (eval '(define$ c 7)) - (test '(1 2 7) eval '(list a b c)) - (eval '(define$ d 8)) - (test '(1 2 7 8) eval '(list a b c d))))]) + (eval '(define$ c 7)) + (test '(1 2 7) eval '(list a b c)) + (eval '(define$ d 8)) + (test '(1 2 7 8) eval '(list a b c d))))]) (go-once eval) (go-once (lambda (e) (eval (expand e))))) @@ -1154,14 +1168,14 @@ (test '(1 2) 'macro-nested-lexical (let () - (define-syntax (m stx) - (with-syntax ([x1 (let ([x 0]) #'x)] - [x2 (let ([x 0]) #'x)]) - #'(begin - (define x1 1) - (define x2 2) - (list x1 x2)))) - (m))) + (define-syntax (m stx) + (with-syntax ([x1 (let ([x 0]) #'x)] + [x2 (let ([x 0]) #'x)]) + #'(begin + (define x1 1) + (define x2 2) + (list x1 x2)))) + (m))) (module @!$m scheme/base (require (for-syntax scheme/base)) @@ -1169,12 +1183,12 @@ (syntax-case stx () [(_ id) (with-syntax ([x1 (let ([x 0]) #'x)] - [x2 (let ([x 0]) #'x)]) - #'(begin - (define x1 10) - (define x2 20) - (define id (list x1 x2 - (list? (identifier-binding (quote-syntax x1)))))))])) + [x2 (let ([x 0]) #'x)]) + #'(begin + (define x1 10) + (define x2 20) + (define id (list x1 x2 + (list? (identifier-binding (quote-syntax x1)))))))])) (d @!$get) (provide @!$get)) (require '@!$m) @@ -1191,21 +1205,21 @@ (define z (list b)) z))]) (goo)))))) - + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Test lazy unmarshaling of renamings and module-name resolution (let ([load-ok? #t] [old (current-module-name-resolver)]) (parameterize ([current-namespace (make-base-namespace)] - [current-module-name-resolver - (case-lambda - [(name) + [current-module-name-resolver + (case-lambda + [(name) (if (equal? name "a") (void) (old name))] - [(name _ __) (make-resolved-module-path 'huh?)] - [(name base stx load?) + [(name _ __) (make-resolved-module-path 'huh?)] + [(name base stx load?) (if (equal? name "a") (begin (unless load-ok? @@ -1213,43 +1227,43 @@ (make-resolved-module-path 'a)) (old name base stx load?))])]) (let ([a-code '(module a scheme/base - (provide x y) - (define x 1) - (define y #'x))]) + (provide x y) + (define x 1) + (define y #'x))]) (eval a-code) (let ([b-code (let ([p (open-output-bytes)]) - (write (compile - '(module b scheme/base - (require "a") - (provide f) - (define (f) #'x))) - p) - (lambda () - (parameterize ([read-accept-compiled #t]) - (read (open-input-bytes (get-output-bytes p))))))] - [x-id (parameterize ([current-namespace (make-base-namespace)]) + (write (compile + '(module b scheme/base + (require "a") + (provide f) + (define (f) #'x))) + p) + (lambda () + (parameterize ([read-accept-compiled #t]) + (read (open-input-bytes (get-output-bytes p))))))] + [x-id (parameterize ([current-namespace (make-base-namespace)]) (printf "here\n") - (eval a-code) - (eval '(require 'a)) - (eval '#'x))]) - (eval (b-code)) - (eval '(require 'b)) - (set! load-ok? #f) - (test #f eval '(free-identifier=? (f) #'x)) - (test #t eval `(free-identifier=? (f) (quote-syntax ,x-id))) - (eval '(require 'a)) - (test #t eval '(free-identifier=? (f) #'x)) - (test #t eval `(free-identifier=? (f) (quote-syntax ,x-id))) - (parameterize ([current-namespace (make-base-namespace)]) - (eval '(module a scheme/base - (provide y) - (define y 3))) - (set! load-ok? #t) - (eval (b-code)) - (eval '(require 'b)) - (set! load-ok? #f) - (test #t eval '(free-identifier=? (f) #'x)) - (test #f eval `(free-identifier=? (f) (quote-syntax ,x-id)))))))) + (eval a-code) + (eval '(require 'a)) + (eval '#'x))]) + (eval (b-code)) + (eval '(require 'b)) + (set! load-ok? #f) + (test #f eval '(free-identifier=? (f) #'x)) + (test #t eval `(free-identifier=? (f) (quote-syntax ,x-id))) + (eval '(require 'a)) + (test #t eval '(free-identifier=? (f) #'x)) + (test #t eval `(free-identifier=? (f) (quote-syntax ,x-id))) + (parameterize ([current-namespace (make-base-namespace)]) + (eval '(module a scheme/base + (provide y) + (define y 3))) + (set! load-ok? #t) + (eval (b-code)) + (eval '(require 'b)) + (set! load-ok? #f) + (test #t eval '(free-identifier=? (f) #'x)) + (test #f eval `(free-identifier=? (f) (quote-syntax ,x-id)))))))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; certification example from the manual @@ -1257,7 +1271,7 @@ (module @-m scheme/base (require (for-syntax scheme/base)) (provide def-go) - (define (unchecked-go n x) + (define (unchecked-go n x) (+ n 17)) (define-syntax (def-go stx) (syntax-case stx () @@ -1275,19 +1289,20 @@ (require '@-n) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Propagating inactive certificates through a transparent macro-expansion result: +;; Propagating inactive certificates through a transparent macro-expansion +;; result: (module @!m scheme/base (require (for-syntax scheme/base)) (provide define-x) - + (define-syntax (define-x stx) (syntax-case stx () [(_ x) #'(define-syntax (x stx) #'(begin (define-y y 10)))])) - + (define-syntax define-y (syntax-rules () [(_ id v) @@ -1305,25 +1320,25 @@ (module @w@ scheme/base (define add '+) - + (provide (rename-out [add plus]))) (module @q@ scheme/base (require (for-syntax scheme/base)) (provide result) - + (define-for-syntax a #'plus) (define-for-syntax b #'plus) (define-for-syntax accum null) - - (begin-for-syntax + + (begin-for-syntax (set! accum (cons (free-identifier=? a #'plus) accum))) (require '@w@) - (begin-for-syntax + (begin-for-syntax (set! accum (list* (free-identifier=? a #'plus) (free-identifier=? b #'plus) @@ -1370,8 +1385,8 @@ (let-syntax ([ref-x (lambda (stx) #`(quote-syntax #,(get-x)))]) (ref-x))) - - (with-output-to-file tmp10 + + (with-output-to-file tmp10 #:exists 'append (lambda () (printf "~s\n" (foo))))) @@ -1405,7 +1420,7 @@ (module @simp@ scheme/base (require (for-syntax scheme/base)) - + (define-syntax-rule (foo) (begin (define-for-syntax goo #'intro) @@ -1414,7 +1429,7 @@ #`(quote #,(identifier-binding goo))) (define @simp@tst (extract)) (provide @simp@tst))) - + (foo)) (require '@simp@) diff --git a/collects/tests/mzscheme/unsafe.ss b/collects/tests/mzscheme/unsafe.ss index 71f7aac5ae..7304c90968 100644 --- a/collects/tests/mzscheme/unsafe.ss +++ b/collects/tests/mzscheme/unsafe.ss @@ -3,7 +3,8 @@ (Section 'unsafe) -(require '#%unsafe) +(require scheme/unsafe/ops + scheme/foreign) (let () (define (test-tri result proc x y z @@ -186,6 +187,21 @@ #:post (lambda (x) (list x (string-ref v 2))) #:literal-ok? #f)) + (test-bin 9.5 'unsafe-flvector-ref (flvector 1.0 9.5 18.7) 1) + (test-un 5 'unsafe-flvector-length (flvector 1.1 2.0 3.1 4.5 5.7)) + (let ([v (flvector 1.0 9.5 18.7)]) + (test-tri (list (void) 27.4) 'unsafe-flvector-set! v 2 27.4 + #:pre (lambda () (flvector-set! v 2 0.0)) + #:post (lambda (x) (list x (flvector-ref v 2))) + #:literal-ok? #f)) + + (test-bin 9.5 'unsafe-f64vector-ref (f64vector 1.0 9.5 18.7) 1) + (let ([v (f64vector 1.0 9.5 18.7)]) + (test-tri (list (void) 27.4) 'unsafe-f64vector-set! v 2 27.4 + #:pre (lambda () (f64vector-set! v 2 0.0)) + #:post (lambda (x) (list x (f64vector-ref v 2))) + #:literal-ok? #f)) + (let () (define-struct posn (x [y #:mutable] z)) (test-bin 'a unsafe-struct-ref (make-posn 'a 'b 'c) 0 #:literal-ok? #f) @@ -195,6 +211,12 @@ #:pre (lambda () (set-posn-y! p 0)) #:post (lambda (x) (posn-y p)) #:literal-ok? #f))) + ;; test unboxing: + (test-tri 5.4 '(lambda (x y z) (unsafe-fl+ x (unsafe-f64vector-ref y z))) 1.2 (f64vector 1.0 4.2 6.7) 1) + (test-tri 3.2 '(lambda (x y z) + (unsafe-f64vector-set! y 1 (unsafe-fl+ x z)) + (unsafe-f64vector-ref y 1)) + 1.2 (f64vector 1.0 4.2 6.7) 2.0) (void)) diff --git a/collects/tests/srfi/19/tests.ss b/collects/tests/srfi/19/tests.ss index c6fa05db59..c12248d6bf 100644 --- a/collects/tests/srfi/19/tests.ss +++ b/collects/tests/srfi/19/tests.ss @@ -1,74 +1,84 @@ -(module tests mzscheme +#lang scheme/base - ;; Tests by Will Fitzgerald, augmented by John Clements -- 2004-08-16 +;; Tests by Will Fitzgerald, augmented by: +;; John Clements -- 2004-08-16 +;; Dave Gurnell (string->date, date->string) -- 2007-09-14 +;; Dave Gurnell (time{=,<,>,<=,>=}?) -- 2009-11-26 - ;; Updated to SchemeUnit 2 syntax by Dave Gurnell -- 2007-09-14 +(require srfi/19/time) - (require srfi/19/time) +(require schemeunit/test + schemeunit/text-ui) - (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) - (planet "text-ui.ss" ("schematics" "schemeunit.plt" 2))) +(define-check (check-comparisons comparison times expected) + (for ([time0 (in-list times)] + [expected (in-list expected)]) + (for ([time1 (in-list times)] + [expected (in-list expected)]) + (with-check-info (['comparison comparison] + ['time0 time0] + ['time1 time1]) + (let ([actual (comparison time0 time1)]) + (check-equal? actual expected)))))) - (define cur-tz (date-zone-offset (current-date))) - - ; Test suite ----------------------------------- +(define cur-tz (date-zone-offset (current-date))) - (define srfi-19-test-suite - (test-suite - "Tests for SRFI 19" +; Test suite ------------------------------------- - (test-not-exn - "Creating time structures" +(define srfi-19-test-suite + (test-suite "Tests for SRFI 19" + + (test-not-exn "Creating time structures" (lambda () (list (current-time 'time-tai) (current-time 'time-utc) (current-time 'time-monotonic) (current-time 'time-thread) (current-time 'time-process)))) - - (test-not-exn - "Testing time resolutions" + + (test-not-exn "Testing time resolutions" (lambda () (list (time-resolution 'time-tai) (time-resolution 'time-utc) (time-resolution 'time-monotonic) (time-resolution 'time-thread) (time-resolution 'time-process)))) - - (test-case - "Time comparisons (time=?, etc.)" - (let ((t1 (make-time 'time-utc 0 1)) - (t2 (make-time 'time-utc 0 1)) - (t3 (make-time 'time-utc 0 2)) - (t11 (make-time 'time-utc 1001 1)) - (t12 (make-time 'time-utc 1001 1)) - (t13 (make-time 'time-utc 1001 2))) - (check time=? t1 t2) - (check time>? t3 t2) - (check time=? t1 t2) - (check time>=? t3 t2) - (check time<=? t1 t2) - (check time<=? t2 t3) - (check time=? t11 t12) - (check time>? t13 t12) - (check time=? t11 t12) - (check time>=? t13 t12) - (check time<=? t11 t12) - (check time<=? t12 t13))) - - (test-case - "Time difference" + + (test-case "Time comparisons (time=?, etc.)" + (let ([t0 (make-time 'time-utc 0 1)] + [t1 (make-time 'time-utc 0 1)] + [t2 (make-time 'time-utc 1 1)] + [t3 (make-time 'time-utc 0 2)]) + (check-comparisons time=? (list t0 t1 t2 t3) '((#t #t #f #f) + (#t #t #f #f) + (#f #f #t #f) + (#f #f #f #t))) + (check-comparisons time? (list t0 t1 t2 t3) '((#f #f #f #f) + (#f #f #f #f) + (#t #t #f #f) + (#t #t #t #f))) + (check-comparisons time<=? (list t0 t1 t2 t3) '((#t #t #t #t) + (#t #t #t #t) + (#f #f #t #t) + (#f #f #f #t))) + (check-comparisons time>=? (list t0 t1 t2 t3) '((#t #t #f #f) + (#t #t #f #f) + (#t #t #t #f) + (#t #t #t #t))))) + + (test-case "Time difference" (let ((t1 (make-time 'time-utc 0 3000)) (t2 (make-time 'time-utc 0 1000)) (t3 (make-time 'time-duration 0 2000)) (t4 (make-time 'time-duration 0 -2000))) (check time=? t3 (time-difference t1 t2)) (check time=? t4 (time-difference t2 t1)))) - - (test-case - "TAI-UTC Conversions" + + (test-case "TAI-UTC Conversions" (check-one-utc-tai-edge 915148800 32 31) (check-one-utc-tai-edge 867715200 31 30) (check-one-utc-tai-edge 820454400 30 29) @@ -95,15 +105,8 @@ (check-one-utc-tai-edge 0 0 0) ;; at the epoch (check-one-utc-tai-edge 10 0 0) ;; close to it ... (check-one-utc-tai-edge 1045789645 32 32)) ;; about now ... - - (test-case - "time-second" - (check-equal? (time-second (make-time 'time-duration 34 52)) 52) - (check-equal? (time-nanosecond (make-time 'time-duration 34 52)) 34)) - - - (test-case - "TAI-Date Conversions" + + (test-case "TAI-Date Conversions" (check tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 29)) 0) (srfi:make-date 0 58 59 23 31 12 1998 0)) (check tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 30)) 0) @@ -112,9 +115,8 @@ (srfi:make-date 0 60 59 23 31 12 1998 0)) (check tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 32)) 0) (srfi:make-date 0 0 0 0 1 1 1999 0))) - - (test-case - "Date-UTC Conversions" + + (test-case "Date-UTC Conversions" (check time=? (make-time time-utc 0 (- 915148800 2)) (date->time-utc (srfi:make-date 0 58 59 23 31 12 1998 0))) (check time=? (make-time time-utc 0 (- 915148800 1)) @@ -126,44 +128,36 @@ (date->time-utc (srfi:make-date 0 0 0 0 1 1 1999 0))) (check time=? (make-time time-utc 0 (+ 915148800 1)) (date->time-utc (srfi:make-date 0 1 0 0 1 1 1999 0)))) - - (test-case - "TZ Offset conversions" + + (test-case "TZ Offset conversions" (let ((ct-utc (make-time time-utc 6320000 1045944859)) (ct-tai (make-time time-tai 6320000 1045944891)) (cd (srfi:make-date 6320000 19 14 15 22 2 2003 -18000))) (check time=? ct-utc (date->time-utc cd)) (check time=? ct-tai (date->time-tai cd)))) - - - ;; NOTE: documentation doesn't fully specify, e.g., zero-padding on ~c option, so I'm just going - ;; to change the test case to match the implementation... - (test-case - "date->string conversions" + + + ;; NOTE: documentation doesn't fully specify, e.g., zero-padding on ~c option, so I'm just going + ;; to change the test case to match the implementation... + (test-case "date->string conversions" (check-equal? (date->string (srfi:make-date 1000 2 3 4 5 6 2007 (* 60 -120)) "~~ @ ~a @ ~A @ ~b @ ~B @ ~c @ ~d @ ~D @ ~e @ ~f @ ~h @ ~H") - "~ @ Tue @ Tuesday @ Jun @ June @ Tue Jun 05 04:03:02-0200 2007 @ 05 @ 06/05/07 @ 5 @ 02.000001 @ Jun @ 04") - (check-equal? (date->string (srfi:make-date 1000 2 3 4 5 6 2007 (* 60 -120)) - "~4") - "2007-06-05T04:03:02-0200")) - - - ;; looks like these tests need to ignore the time zone. -- JBC, 2009-08-27 - - (test-case - "[DJG] date->string conversions of dates with nanosecond components" - (check-equal? (date->string (srfi:make-date 123456789 2 3 4 5 6 2007 cur-tz) "~N") "123456789") - (check-equal? (date->string (srfi:make-date 12345678 2 3 4 5 6 2007 cur-tz) "~N") "012345678") - (check-equal? (date->string (srfi:make-date 1234567 2 3 4 5 6 2007 cur-tz) "~N") "001234567") - (check-equal? (date->string (srfi:make-date 123456 2 3 4 5 6 2007 cur-tz) "~N") "000123456") - (check-equal? (date->string (srfi:make-date 12345 2 3 4 5 6 2007 cur-tz) "~N") "000012345") - (check-equal? (date->string (srfi:make-date 1234 2 3 4 5 6 2007 cur-tz) "~N") "000001234") - (check-equal? (date->string (srfi:make-date 123 2 3 4 5 6 2007 cur-tz) "~N") "000000123") - (check-equal? (date->string (srfi:make-date 12 2 3 4 5 6 2007 cur-tz) "~N") "000000012") - (check-equal? (date->string (srfi:make-date 1 2 3 4 5 6 2007 cur-tz) "~N") "000000001")) - - (test-case - "[DJG] string->date conversions of dates with nanosecond components" + "~ @ Tue @ Tuesday @ Jun @ June @ Tue Jun 05 04:03:02-0200 2007 @ 05 @ 06/05/07 @ 5 @ 02.000001 @ Jun @ 04")) + + + + (test-case "[DJG] date->string conversions of dates with nanosecond components" + (check-equal? (date->string (srfi:make-date 123456789 2 3 4 5 6 2007 0) "~N") "123456789") + (check-equal? (date->string (srfi:make-date 12345678 2 3 4 5 6 2007 0) "~N") "012345678") + (check-equal? (date->string (srfi:make-date 1234567 2 3 4 5 6 2007 0) "~N") "001234567") + (check-equal? (date->string (srfi:make-date 123456 2 3 4 5 6 2007 0) "~N") "000123456") + (check-equal? (date->string (srfi:make-date 12345 2 3 4 5 6 2007 0) "~N") "000012345") + (check-equal? (date->string (srfi:make-date 1234 2 3 4 5 6 2007 0) "~N") "000001234") + (check-equal? (date->string (srfi:make-date 123 2 3 4 5 6 2007 0) "~N") "000000123") + (check-equal? (date->string (srfi:make-date 12 2 3 4 5 6 2007 0) "~N") "000000012") + (check-equal? (date->string (srfi:make-date 1 2 3 4 5 6 2007 0) "~N") "000000001")) + + (test-case "[DJG] string->date conversions of dates with nanosecond components" (check-equal? (string->date "12:00:00.123456789" "~H:~M:~S.~N") (srfi:make-date 123456789 0 0 12 #t #t #t cur-tz) "check 1") (check-equal? (string->date "12:00:00.12345678" "~H:~M:~S.~N") (srfi:make-date 123456780 0 0 12 #t #t #t cur-tz) "check 2") (check-equal? (string->date "12:00:00.1234567" "~H:~M:~S.~N") (srfi:make-date 123456700 0 0 12 #t #t #t cur-tz) "check 3") @@ -182,73 +176,67 @@ (check-equal? (string->date "12:00:00.000000123" "~H:~M:~S.~N") (srfi:make-date 123 0 0 12 #t #t #t cur-tz) "check 16") (check-equal? (string->date "12:00:00.000000012" "~H:~M:~S.~N") (srfi:make-date 12 0 0 12 #t #t #t cur-tz) "check 17") (check-equal? (string->date "12:00:00.000000001" "~H:~M:~S.~N") (srfi:make-date 1 0 0 12 #t #t #t cur-tz) "check 18")) - - (test-case - "date<->julian-day conversion" + + (test-case "date<->julian-day conversion" (check = 365 (- (date->julian-day (srfi:make-date 0 0 0 0 1 1 2004 0)) (date->julian-day (srfi:make-date 0 0 0 0 1 1 2003 0)))) (let ([test-date (srfi:make-date 0 0 0 0 1 1 2003 -7200)]) (check tm:date= test-date (julian-day->date (date->julian-day test-date) -7200)))) - - (test-case - "date->modified-julian-day conversion" + + (test-case "date->modified-julian-day conversion" (check = 365 (- (date->modified-julian-day (srfi:make-date 0 0 0 0 1 1 2004 0)) (date->modified-julian-day (srfi:make-date 0 0 0 0 1 1 2003 0)))) (let ([test-date (srfi:make-date 0 0 0 0 1 1 2003 -7200)]) - (check tm:date= test-date (modified-julian-day->date (date->modified-julian-day test-date) -7200)))) + (check tm:date= test-date (modified-julian-day->date (date->modified-julian-day test-date) -7200)))))) - )) +; Helper checks and procedures ----------------- - ; Helper checks and procedures ----------------- +(define-check (check-one-utc-tai-edge utc tai-diff tai-last-diff) + (let* (;; right on the edge they should be the same + (utc-basic (make-time 'time-utc 0 utc)) + (tai-basic (make-time 'time-tai 0 (+ utc tai-diff))) + (utc->tai-basic (time-utc->time-tai utc-basic)) + (tai->utc-basic (time-tai->time-utc tai-basic)) + + ;; a second before they should be the old diff + (utc-basic-1 (make-time 'time-utc 0 (- utc 1))) + (tai-basic-1 (make-time 'time-tai 0 (- (+ utc tai-last-diff) 1))) + (utc->tai-basic-1 (time-utc->time-tai utc-basic-1)) + (tai->utc-basic-1 (time-tai->time-utc tai-basic-1)) + + ;; a second later they should be the new diff + (utc-basic+1 (make-time 'time-utc 0 (+ utc 1))) + (tai-basic+1 (make-time 'time-tai 0 (+ (+ utc tai-diff) 1))) + (utc->tai-basic+1 (time-utc->time-tai utc-basic+1)) + (tai->utc-basic+1 (time-tai->time-utc tai-basic+1)) + + ;; ok, let's move the clock half a month or so plus half a second + (shy (* 15 24 60 60)) + (hs (/ (expt 10 9) 2)) + ;; a second later they should be the new diff + (utc-basic+2 (make-time 'time-utc hs (+ utc shy))) + (tai-basic+2 (make-time 'time-tai hs (+ (+ utc tai-diff) shy))) + (utc->tai-basic+2 (time-utc->time-tai utc-basic+2)) + (tai->utc-basic+2 (time-tai->time-utc tai-basic+2))) + + (check time=? utc-basic tai->utc-basic) + (check time=? tai-basic utc->tai-basic) + (check time=? utc-basic-1 tai->utc-basic-1) + (check time=? tai-basic-1 utc->tai-basic-1) + (check time=? utc-basic+1 tai->utc-basic+1) + (check time=? tai-basic+1 utc->tai-basic+1) + (check time=? utc-basic+2 tai->utc-basic+2) + (check time=? tai-basic+2 utc->tai-basic+2))) - (define-check (check-one-utc-tai-edge utc tai-diff tai-last-diff) - (let* (;; right on the edge they should be the same - (utc-basic (make-time 'time-utc 0 utc)) - (tai-basic (make-time 'time-tai 0 (+ utc tai-diff))) - (utc->tai-basic (time-utc->time-tai utc-basic)) - (tai->utc-basic (time-tai->time-utc tai-basic)) +(define (tm:date= d1 d2) + (and (= (srfi:date-year d1) (srfi:date-year d2)) + (= (srfi:date-month d1) (srfi:date-month d2)) + (= (srfi:date-day d1) (srfi:date-day d2)) + (= (srfi:date-hour d1) (srfi:date-hour d2)) + (= (srfi:date-second d1) (srfi:date-second d2)) + (= (date-nanosecond d1) (date-nanosecond d2)) + (= (date-zone-offset d1) (date-zone-offset d2)))) - ;; a second before they should be the old diff - (utc-basic-1 (make-time 'time-utc 0 (- utc 1))) - (tai-basic-1 (make-time 'time-tai 0 (- (+ utc tai-last-diff) 1))) - (utc->tai-basic-1 (time-utc->time-tai utc-basic-1)) - (tai->utc-basic-1 (time-tai->time-utc tai-basic-1)) +; Main module body ------------------------------- - ;; a second later they should be the new diff - (utc-basic+1 (make-time 'time-utc 0 (+ utc 1))) - (tai-basic+1 (make-time 'time-tai 0 (+ (+ utc tai-diff) 1))) - (utc->tai-basic+1 (time-utc->time-tai utc-basic+1)) - (tai->utc-basic+1 (time-tai->time-utc tai-basic+1)) - - ;; ok, let's move the clock half a month or so plus half a second - (shy (* 15 24 60 60)) - (hs (/ (expt 10 9) 2)) - ;; a second later they should be the new diff - (utc-basic+2 (make-time 'time-utc hs (+ utc shy))) - (tai-basic+2 (make-time 'time-tai hs (+ (+ utc tai-diff) shy))) - (utc->tai-basic+2 (time-utc->time-tai utc-basic+2)) - (tai->utc-basic+2 (time-tai->time-utc tai-basic+2))) - - (check time=? utc-basic tai->utc-basic) - (check time=? tai-basic utc->tai-basic) - (check time=? utc-basic-1 tai->utc-basic-1) - (check time=? tai-basic-1 utc->tai-basic-1) - (check time=? utc-basic+1 tai->utc-basic+1) - (check time=? tai-basic+1 utc->tai-basic+1) - (check time=? utc-basic+2 tai->utc-basic+2) - (check time=? tai-basic+2 utc->tai-basic+2))) - - (define (tm:date= d1 d2) - (and (= (srfi:date-year d1) (srfi:date-year d2)) - (= (srfi:date-month d1) (srfi:date-month d2)) - (= (srfi:date-day d1) (srfi:date-day d2)) - (= (srfi:date-hour d1) (srfi:date-hour d2)) - (= (srfi:date-second d1) (srfi:date-second d2)) - (= (date-nanosecond d1) (date-nanosecond d2)) - (= (date-zone-offset d1) (date-zone-offset d2)))) - - ; Main module body ----------------------------- - - (test/text-ui srfi-19-test-suite) - - ) +(run-tests srfi-19-test-suite) diff --git a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss index a62938aacc..973c53ad7c 100644 --- a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss @@ -96,6 +96,7 @@ [#t (-val #t)] [#f (-val #f)] ["foo" (-val "foo")] + ['(1 2 3) (-Tuple (map -val '(1 2 3)))] [(Listof Number) (make-Listof N)] diff --git a/collects/tests/unstable/srcloc.ss b/collects/tests/unstable/srcloc.ss new file mode 100644 index 0000000000..299cbf07b8 --- /dev/null +++ b/collects/tests/unstable/srcloc.ss @@ -0,0 +1,305 @@ + +(load-relative "../mzscheme/loadtest.ss") + +(Section 'srcloc) +(require unstable/srcloc) +(require scheme/shared) + +(test #t source-location? #f) +(test #f source-location? #t) +(test #t source-location? (list #f #f #f #f #f)) +(test #t source-location? (list 'here 1 0 1 0)) +(test #t source-location? (list #f 1 0 1 0)) +(test #f source-location? (list 'here #f 0 1 0)) +(test #f source-location? (list 'here 1 #f 1 0)) +(test #t source-location? (list 'here 1 0 #f 0)) +(test #t source-location? (list 'here 1 0 1 #f)) +(test #f source-location? (list 'here 1 -1 1 0)) +(test #f source-location? (list 'here 1 0 0 0)) +(test #f source-location? (list 'here 1 0 1 -1)) +(test #f source-location? (shared ([x (list* 'here 1 0 1 0 x)]) x)) +(test #t source-location? (vector #f #f #f #f #f)) +(test #t source-location? (vector 'here 1 0 1 0)) +(test #t source-location? (vector #f 1 0 1 0)) +(test #f source-location? (vector 'here #f 0 1 0)) +(test #f source-location? (vector 'here 1 #f 1 0)) +(test #t source-location? (vector 'here 1 0 #f 0)) +(test #t source-location? (vector 'here 1 0 1 #f)) +(test #f source-location? (vector 'here 0 0 1 0)) +(test #f source-location? (vector 'here 1 -1 1 0)) +(test #f source-location? (vector 'here 1 0 0 0)) +(test #f source-location? (vector 'here 1 0 1 -1)) +(test #t source-location? (make-srcloc #f #f #f #f #f)) +(test #t source-location? (make-srcloc 'here 1 0 1 0)) +(test #t source-location? (make-srcloc #f 1 0 1 0)) +(test #f source-location? (make-srcloc 'here #f 0 1 0)) +(test #f source-location? (make-srcloc 'here 1 #f 1 0)) +(test #t source-location? (make-srcloc 'here 1 0 #f 0)) +(test #t source-location? (make-srcloc 'here 1 0 1 #f)) +(test #t source-location? (datum->syntax #f null #f)) +(test #t source-location? (datum->syntax #f null (list 'here 1 0 1 0))) +(test #t source-location? (datum->syntax #f null (list #f 1 0 1 0))) +;;(test #f source-location? (datum->syntax #f null (list 'here #f 0 1 0))) ;; won't run +;;(test #f source-location? (datum->syntax #f null (list 'here 1 #f 1 0))) ;; won't run +(test #t source-location? (datum->syntax #f null (list 'here 1 0 #f 0))) +(test #t source-location? (datum->syntax #f null (list 'here 1 0 1 #f))) + +(test #f source-location-list? #f) +(test #t source-location-list? (list #f #f #f #f #f)) +(test #t source-location-list? (list 'here 1 0 1 0)) +(test #t source-location-list? (list #f 1 0 1 0)) +(test #f source-location-list? (list 'here #f 0 1 0)) +(test #f source-location-list? (list 'here 1 #f 1 0)) +(test #t source-location-list? (list 'here 1 0 #f 0)) +(test #t source-location-list? (list 'here 1 0 1 #f)) +(test #f source-location-list? (list 'here 0 0 1 0)) +(test #f source-location-list? (list 'here 1 -1 1 0)) +(test #f source-location-list? (list 'here 1 0 0 0)) +(test #f source-location-list? (list 'here 1 0 1 -1)) +(test #f source-location-list? (shared ([x (list* 'here 1 0 1 0 x)]) x)) +(test #f source-location-list? (vector 'here 1 0 1 0)) +(test #f source-location-list? (make-srcloc 'here 1 0 1 0)) +(test #f source-location-list? (datum->syntax #f null #f)) +(test #f source-location-list? (datum->syntax #f null (list 'here 1 0 1 0))) + +(test #f source-location-vector? #f) +(test #f source-location-vector? (list 'here 1 0 1 0)) +(test #t source-location-vector? (vector #f 1 0 1 0)) +(test #f source-location-vector? (vector 'here #f 0 1 0)) +(test #f source-location-vector? (vector 'here 1 #f 1 0)) +(test #t source-location-vector? (vector 'here 1 0 #f 0)) +(test #t source-location-vector? (vector 'here 1 0 1 #f)) +(test #t source-location-vector? (vector #f #f #f #f #f)) +(test #t source-location-vector? (vector 'here 1 0 1 0)) +(test #f source-location-vector? (vector 'here 0 0 1 0)) +(test #f source-location-vector? (vector 'here 1 -1 1 0)) +(test #f source-location-vector? (vector 'here 1 0 0 0)) +(test #f source-location-vector? (vector 'here 1 0 1 -1)) +(test #f source-location-vector? (make-srcloc 'here 1 0 1 0)) +(test #f source-location-vector? (datum->syntax #f null #f)) +(test #f source-location-vector? (datum->syntax #f null (list 'here 1 0 1 0))) + +(test (void) check-source-location! 'test-srcloc #f) +(err/rt-test (check-source-location! 'test-srcloc #t) exn:fail:contract?) +(test (void) check-source-location! 'test-srcloc (list #f #f #f #f #f)) +(test (void) check-source-location! 'test-srcloc (list 'here 1 0 1 0)) +(test (void) check-source-location! 'test-srcloc (list #f 1 0 1 0)) +(err/rt-test (check-source-location! 'test-srcloc (list 'here #f 0 1 0)) exn:fail:contract?) +(err/rt-test (check-source-location! 'test-srcloc (list 'here 1 #f 1 0)) exn:fail:contract?) +(test (void) check-source-location! 'test-srcloc (list 'here 1 0 #f 0)) +(test (void) check-source-location! 'test-srcloc (list 'here 1 0 1 #f)) +(err/rt-test (check-source-location! 'test-srcloc (list 'here 0 0 1 0)) exn:fail:contract?) +(err/rt-test (check-source-location! 'test-srcloc (list 'here 1 -1 1 0)) exn:fail:contract?) +(err/rt-test (check-source-location! 'test-srcloc (list 'here 1 0 0 0)) exn:fail:contract?) +(err/rt-test (check-source-location! 'test-srcloc (list 'here 1 0 1 -1)) exn:fail:contract?) +(err/rt-test (check-source-location! 'test-srcloc (shared ([x (list* 'here 1 0 1 0 x)]) x)) exn:fail:contract?) +(test (void) check-source-location! 'test-srcloc (vector #f #f #f #f #f)) +(test (void) check-source-location! 'test-srcloc (vector 'here 1 0 1 0)) +(test (void) check-source-location! 'test-srcloc (vector #f 1 0 1 0)) +(err/rt-test (check-source-location! 'test-srcloc (vector 'here #f 0 1 0)) exn:fail:contract?) +(err/rt-test (check-source-location! 'test-srcloc (vector 'here 1 #f 1 0)) exn:fail:contract?) +(test (void) check-source-location! 'test-srcloc (vector 'here 1 0 #f 0)) +(test (void) check-source-location! 'test-srcloc (vector 'here 1 0 1 #f)) +(err/rt-test (check-source-location! 'test-srcloc (vector 'here 0 0 1 0)) exn:fail:contract?) +(err/rt-test (check-source-location! 'test-srcloc (vector 'here 1 -1 1 0)) exn:fail:contract?) +(err/rt-test (check-source-location! 'test-srcloc (vector 'here 1 0 0 0)) exn:fail:contract?) +(err/rt-test (check-source-location! 'test-srcloc (vector 'here 1 0 1 -1)) exn:fail:contract?) +(test (void) check-source-location! 'test-srcloc (make-srcloc #f #f #f #f #f)) +(test (void) check-source-location! 'test-srcloc (make-srcloc 'here 1 0 1 0)) +(test (void) check-source-location! 'test-srcloc (make-srcloc #f 1 0 1 0)) +(err/rt-test (check-source-location! 'test-srcloc (make-srcloc 'here #f 0 1 0)) exn:fail:contract?) +(err/rt-test (check-source-location! 'test-srcloc (make-srcloc 'here 1 #f 1 0)) exn:fail:contract?) +(test (void) check-source-location! 'test-srcloc (make-srcloc 'here 1 0 #f 0)) +(test (void) check-source-location! 'test-srcloc (make-srcloc 'here 1 0 1 #f)) +(test (void) check-source-location! 'test-srcloc (datum->syntax #f null #f)) +(test (void) check-source-location! 'test-srcloc (datum->syntax #f null (list 'here 1 0 1 0))) +(test (void) check-source-location! 'test-srcloc (datum->syntax #f null (list #f 1 0 1 0))) +;;(err/rt-test (check-source-location! 'test-srcloc (datum->syntax #f null (list 'here #f 0 1 0))) exn:fail:contract?) ;; won't run +;;(err/rt-test (check-source-location! 'test-srcloc (datum->syntax #f null (list 'here 1 #f 1 0))) exn:fail:contract?) ;; won't run +(test (void) check-source-location! 'test-srcloc (datum->syntax #f null (list 'here 1 0 #f 0))) +(test (void) check-source-location! 'test-srcloc (datum->syntax #f null (list 'here 1 0 1 #f))) + +(test (make-srcloc #f #f #f #f #f) build-source-location) +(test (make-srcloc #f #f #f #f #f) build-source-location #f) +(test (make-srcloc 'here 1 0 1 0) build-source-location (make-srcloc 'here 1 0 1 0)) +(test (make-srcloc 'here 1 0 1 0) build-source-location (vector 'here 1 0 1 0)) +(test (make-srcloc 'here 1 0 1 0) build-source-location (list 'here 1 0 1 0)) +(test (make-srcloc 'here 1 0 1 0) build-source-location (datum->syntax #f null (list 'here 1 0 1 0))) +(test (make-srcloc 'here 1 0 1 3) build-source-location (list 'here 1 0 1 0) (vector 'here 2 1 3 1)) +(test (make-srcloc 'here 1 0 1 3) build-source-location (vector 'here 2 1 3 1) (list 'here 1 0 1 0)) +(test (make-srcloc #f #f #f #f #f) build-source-location (vector 'here 2 1 3 1) (list 'there 1 0 1 0)) +(err/rt-test (build-source-location (list 'bad 0 0 0 0)) exn:fail:contract?) + +(test (list #f #f #f #f #f) build-source-location-list) +(test (list #f #f #f #f #f) build-source-location-list #f) +(test (list 'here 1 0 1 0) build-source-location-list (make-srcloc 'here 1 0 1 0)) +(test (list 'here 1 0 1 0) build-source-location-list (vector 'here 1 0 1 0)) +(test (list 'here 1 0 1 0) build-source-location-list (list 'here 1 0 1 0)) +(test (list 'here 1 0 1 0) build-source-location-list (datum->syntax #f null (list 'here 1 0 1 0))) +(test (list 'here 1 0 1 3) build-source-location-list (list 'here 1 0 1 0) (vector 'here 2 1 3 1)) +(test (list 'here 1 0 1 3) build-source-location-list (vector 'here 2 1 3 1) (list 'here 1 0 1 0)) +(test (list #f #f #f #f #f) build-source-location-list (vector 'here 2 1 3 1) (list 'there 1 0 1 0)) +(err/rt-test (build-source-location-list (list 'bad 0 0 0 0)) exn:fail:contract?) + +(test (vector #f #f #f #f #f) build-source-location-vector) +(test (vector #f #f #f #f #f) build-source-location-vector #f) +(test (vector 'here 1 0 1 0) build-source-location-vector (make-srcloc 'here 1 0 1 0)) +(test (vector 'here 1 0 1 0) build-source-location-vector (vector 'here 1 0 1 0)) +(test (vector 'here 1 0 1 0) build-source-location-vector (list 'here 1 0 1 0)) +(test (vector 'here 1 0 1 0) build-source-location-vector (datum->syntax #f null (list 'here 1 0 1 0))) +(test (vector 'here 1 0 1 3) build-source-location-vector (list 'here 1 0 1 0) (vector 'here 2 1 3 1)) +(test (vector 'here 1 0 1 3) build-source-location-vector (vector 'here 2 1 3 1) (list 'here 1 0 1 0)) +(test (vector #f #f #f #f #f) build-source-location-vector (vector 'here 2 1 3 1) (list 'there 1 0 1 0)) +(err/rt-test (build-source-location-vector (list 'bad 0 0 0 0)) exn:fail:contract?) + +(define-syntax-rule (test-stx-srcloc (list src line col pos span) fn arg ...) + (begin + (test #t syntax? (fn arg ...)) + (test src syntax-source (fn arg ...)) + (test line syntax-line (fn arg ...)) + (test col syntax-column (fn arg ...)) + (test pos syntax-position (fn arg ...)) + (test span syntax-span (fn arg ...)))) + +(test-stx-srcloc (list #f #f #f #f #f) build-source-location-syntax) +(test-stx-srcloc (list #f #f #f #f #f) build-source-location-syntax #f) +(test-stx-srcloc (list 'here 1 0 1 0) build-source-location-syntax (make-srcloc 'here 1 0 1 0)) +(test-stx-srcloc (list 'here 1 0 1 0) build-source-location-syntax (vector 'here 1 0 1 0)) +(test-stx-srcloc (list 'here 1 0 1 0) build-source-location-syntax (list 'here 1 0 1 0)) +(test-stx-srcloc (list 'here 1 0 1 0) build-source-location-syntax (datum->syntax #f null (list 'here 1 0 1 0))) +(test-stx-srcloc (list 'here 1 0 1 3) build-source-location-syntax (list 'here 1 0 1 0) (vector 'here 2 1 3 1)) +(test-stx-srcloc (list 'here 1 0 1 3) build-source-location-syntax (vector 'here 2 1 3 1) (list 'here 1 0 1 0)) +(test-stx-srcloc (list #f #f #f #f #f) build-source-location-syntax (vector 'here 2 1 3 1) (list 'there 1 0 1 0)) +(err/rt-test (build-source-location-syntax (list 'bad 0 0 0 0)) exn:fail:contract?) + +(test #f source-location-known? #f) +(test #t source-location-known? (list 'here 1 0 1 0)) +(test #f source-location-known? (list #f #f #f #f #f)) +(test #t source-location-known? (vector 'here 1 0 1 0)) +(test #f source-location-known? (vector #f #f #f #f #f)) +(test #t source-location-known? (make-srcloc 'here 1 0 1 0)) +(test #f source-location-known? (make-srcloc #f #f #f #f #f)) +(test #t source-location-known? (datum->syntax #f null (list 'here 1 0 1 0))) +(test #f source-location-known? (datum->syntax #f null (list #f #f #f #f #f))) + +(test #f source-location-source #f) +(test 'here source-location-source (list 'here 1 2 3 4)) +(test 'here source-location-source (vector 'here 1 2 3 4)) +(test 'here source-location-source (make-srcloc 'here 1 2 3 4)) +(test 'here source-location-source (datum->syntax #f null (list 'here 1 2 3 4))) + +(test #f source-location-line #f) +(test 1 source-location-line (list 'here 1 2 3 4)) +(test 1 source-location-line (vector 'here 1 2 3 4)) +(test 1 source-location-line (make-srcloc 'here 1 2 3 4)) +(test 1 source-location-line (datum->syntax #f null (list 'here 1 2 3 4))) + +(test #f source-location-column #f) +(test 2 source-location-column (list 'here 1 2 3 4)) +(test 2 source-location-column (vector 'here 1 2 3 4)) +(test 2 source-location-column (make-srcloc 'here 1 2 3 4)) +(test 2 source-location-column (datum->syntax #f null (list 'here 1 2 3 4))) + +(test #f source-location-position #f) +(test 3 source-location-position (list 'here 1 2 3 4)) +(test 3 source-location-position (vector 'here 1 2 3 4)) +(test 3 source-location-position (make-srcloc 'here 1 2 3 4)) +(test 3 source-location-position (datum->syntax #f null (list 'here 1 2 3 4))) + +(test #f source-location-span #f) +(test 4 source-location-span (list 'here 1 2 3 4)) +(test 4 source-location-span (vector 'here 1 2 3 4)) +(test 4 source-location-span (make-srcloc 'here 1 2 3 4)) +(test 4 source-location-span (datum->syntax #f null (list 'here 1 2 3 4))) + +(test #f source-location-end #f) +(test 7 source-location-end (list 'here 1 2 3 4)) +(test #f source-location-end (list 'here 1 2 #f 4)) +(test #f source-location-end (list 'here 1 2 3 #f)) +(test 7 source-location-end (vector 'here 1 2 3 4)) +(test #f source-location-end (vector 'here 1 2 #f 4)) +(test #f source-location-end (vector 'here 1 2 3 #f)) +(test 7 source-location-end (make-srcloc 'here 1 2 3 4)) +(test #f source-location-end (make-srcloc 'here 1 2 #f 4)) +(test #f source-location-end (make-srcloc 'here 1 2 3 #f)) +(test 7 source-location-end (datum->syntax #f null (list 'here 1 2 3 4))) +(test #f source-location-end (datum->syntax #f null (list 'here 1 2 #f 4))) +(test #f source-location-end (datum->syntax #f null (list 'here 1 2 3 #f))) + +(test "" source-location->string #f) + +(test "" source-location->string (list #f #f #f #f #f)) +(test "here" source-location->string (list 'here #f #f #f #f)) +(test "here:1.2" source-location->string (list 'here 1 2 3 #f)) +(test "here::3" source-location->string (list 'here #f #f 3 #f)) +(test "::3-7" source-location->string (list #f #f #f 3 4)) +(test ":1.2" source-location->string (list #f 1 2 3 #f)) +(test "::3" source-location->string (list #f #f #f 3 #f)) +(test "::3-7" source-location->string (list #f #f #f 3 4)) + +(test "" source-location->string (vector #f #f #f #f #f)) +(test "here" source-location->string (vector 'here #f #f #f #f)) +(test "here:1.2" source-location->string (vector 'here 1 2 3 #f)) +(test "here::3" source-location->string (vector 'here #f #f 3 #f)) +(test "::3-7" source-location->string (vector #f #f #f 3 4)) +(test ":1.2" source-location->string (vector #f 1 2 3 #f)) +(test "::3" source-location->string (vector #f #f #f 3 #f)) +(test "::3-7" source-location->string (vector #f #f #f 3 4)) + +(test "" source-location->string (make-srcloc #f #f #f #f #f)) +(test "here" source-location->string (make-srcloc 'here #f #f #f #f)) +(test "here:1.2" source-location->string (make-srcloc 'here 1 2 3 #f)) +(test "here::3" source-location->string (make-srcloc 'here #f #f 3 #f)) +(test "::3-7" source-location->string (make-srcloc #f #f #f 3 4)) +(test ":1.2" source-location->string (make-srcloc #f 1 2 3 #f)) +(test "::3" source-location->string (make-srcloc #f #f #f 3 #f)) +(test "::3-7" source-location->string (make-srcloc #f #f #f 3 4)) + +(test "" source-location->string (datum->syntax #f null (list #f #f #f #f #f))) +(test "here" source-location->string (datum->syntax #f null (list 'here #f #f #f #f))) +(test "here:1.2" source-location->string (datum->syntax #f null (list 'here 1 2 3 #f))) +(test "here::3" source-location->string (datum->syntax #f null (list 'here #f #f 3 #f))) +(test "::3-7" source-location->string (datum->syntax #f null (list #f #f #f 3 4))) +(test ":1.2" source-location->string (datum->syntax #f null (list #f 1 2 3 #f))) +(test "::3" source-location->string (datum->syntax #f null (list #f #f #f 3 #f))) +(test "::3-7" source-location->string (datum->syntax #f null (list #f #f #f 3 4))) + +(test "" source-location->prefix #f) + +(test "" source-location->prefix (list #f #f #f #f #f)) +(test "here: " source-location->prefix (list 'here #f #f #f #f)) +(test "here:1.2: " source-location->prefix (list 'here 1 2 3 #f)) +(test "here::3: " source-location->prefix (list 'here #f #f 3 #f)) +(test "::3-7: " source-location->prefix (list #f #f #f 3 4)) +(test ":1.2: " source-location->prefix (list #f 1 2 3 #f)) +(test "::3: " source-location->prefix (list #f #f #f 3 #f)) +(test "::3-7: " source-location->prefix (list #f #f #f 3 4)) + +(test "" source-location->prefix (vector #f #f #f #f #f)) +(test "here: " source-location->prefix (vector 'here #f #f #f #f)) +(test "here:1.2: " source-location->prefix (vector 'here 1 2 3 #f)) +(test "here::3: " source-location->prefix (vector 'here #f #f 3 #f)) +(test "::3-7: " source-location->prefix (vector #f #f #f 3 4)) +(test ":1.2: " source-location->prefix (vector #f 1 2 3 #f)) +(test "::3: " source-location->prefix (vector #f #f #f 3 #f)) +(test "::3-7: " source-location->prefix (vector #f #f #f 3 4)) + +(test "" source-location->prefix (make-srcloc #f #f #f #f #f)) +(test "here: " source-location->prefix (make-srcloc 'here #f #f #f #f)) +(test "here:1.2: " source-location->prefix (make-srcloc 'here 1 2 3 #f)) +(test "here::3: " source-location->prefix (make-srcloc 'here #f #f 3 #f)) +(test "::3-7: " source-location->prefix (make-srcloc #f #f #f 3 4)) +(test ":1.2: " source-location->prefix (make-srcloc #f 1 2 3 #f)) +(test "::3: " source-location->prefix (make-srcloc #f #f #f 3 #f)) +(test "::3-7: " source-location->prefix (make-srcloc #f #f #f 3 4)) + +(test "" source-location->prefix (datum->syntax #f null (list #f #f #f #f #f))) +(test "here: " source-location->prefix (datum->syntax #f null (list 'here #f #f #f #f))) +(test "here:1.2: " source-location->prefix (datum->syntax #f null (list 'here 1 2 3 #f))) +(test "here::3: " source-location->prefix (datum->syntax #f null (list 'here #f #f 3 #f))) +(test "::3-7: " source-location->prefix (datum->syntax #f null (list #f #f #f 3 4))) +(test ":1.2: " source-location->prefix (datum->syntax #f null (list #f 1 2 3 #f))) +(test "::3: " source-location->prefix (datum->syntax #f null (list #f #f #f 3 #f))) +(test "::3-7: " source-location->prefix (datum->syntax #f null (list #f #f #f 3 4))) + +(report-errs) diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss index f3db1d68c8..d075618442 100644 --- a/collects/typed-scheme/private/parse-type.ss +++ b/collects/typed-scheme/private/parse-type.ss @@ -66,6 +66,12 @@ (make-Poly vars (parse-type #'t))))] [(t:All . rest) (tc-error "All: bad syntax")])) +(define-splicing-syntax-class keyword-tys + (pattern (~seq k:keyword t:expr) + #:attr Keyword (make-Keyword (syntax-e #'k) (parse-type #'t) #t)) + (pattern (~seq [k:keyword t:expr]) + #:attr Keyword (make-Keyword (syntax-e #'k) (parse-type #'t) #f))) + (define (parse-type stx) (parameterize ([current-orig-stx stx]) (syntax-parse @@ -119,10 +125,15 @@ (add-type-name-reference #'kw) ;; use parse-type instead of parse-values-type because we need to add the filters from the pred-ty (make-pred-ty (list (parse-type #'dom)) (parse-type #'rng) (parse-type #'pred-ty))] - [(dom ... rest ddd:star (~and kw t:->) rng) + [(dom:expr ... rest:expr ddd:star kws:keyword-tys ... (~and kw t:->) rng) (add-type-name-reference #'kw) - (->* (map parse-type (syntax->list #'(dom ...))) (parse-type #'rest) (parse-values-type #'rng))] - [(dom ... rest :ddd/bound (~and kw t:->) rng) + (make-Function + (list (make-arr + (map parse-type (syntax->list #'(dom ...))) + (parse-values-type #'rng) + #:rest (parse-type #'rest) + #:kws (attribute kws.Keyword))))] + [(dom:expr ... rest:expr :ddd/bound (~and kw t:->) rng) (add-type-name-reference #'kw) (let ([var (lookup (current-tvars) (syntax-e #'bound) (lambda (_) #f))]) (if (not (Dotted? var)) @@ -141,7 +152,7 @@ (current-tvars))]) (parse-type #'rest)) (syntax-e #'bound))))))] - [(dom ... rest _:ddd (~and kw t:->) rng) + [(dom:expr ... rest:expr _:ddd (~and kw t:->) rng) (add-type-name-reference #'kw) (let ([bounds (filter (compose Dotted? cdr) (env-keys+vals (current-tvars)))]) @@ -160,11 +171,19 @@ (current-tvars))]) (parse-type #'rest)) var)))))] - ;; has to be below the previous one - [(dom ... (~and kw t:->) rng) + #| ;; has to be below the previous one + [(dom:expr ... (~and kw t:->) rng) (add-type-name-reference #'kw) (->* (map parse-type (syntax->list #'(dom ...))) - (parse-values-type #'rng))] + (parse-values-type #'rng))] |# + ;; use expr to rule out keywords + [(dom:expr ... kws:keyword-tys ... (~and kw t:->) rng) + (add-type-name-reference #'kw) + (make-Function + (list (make-arr + (map parse-type (syntax->list #'(dom ...))) + (parse-values-type #'rng) + #:kws (attribute kws.Keyword))))] [((~and kw case-lambda) tys ...) (add-type-name-reference #'kw) (make-Function @@ -194,9 +213,12 @@ [((~and kw t:U) ts ...) (add-type-name-reference #'kw) (apply Un (map parse-type (syntax->list #'(ts ...))))] + [((~and kw quote) (t1 . t2)) + (add-type-name-reference #'kw) + (-pair (parse-type #'(quote t1)) (parse-type #'(quote t2)))] [((~and kw quote) t) (add-type-name-reference #'kw) - (-val (syntax-e #'t))] + (-val (syntax->datum #'t))] #; [(All-kw . rest) #:fail-unless (eq? 'All (syntax-e #'All-kw)) #f diff --git a/collects/typed-scheme/private/type-contract.ss b/collects/typed-scheme/private/type-contract.ss index 6e348b964e..5ac589a9d3 100644 --- a/collects/typed-scheme/private/type-contract.ss +++ b/collects/typed-scheme/private/type-contract.ss @@ -70,25 +70,34 @@ [(Function: arrs) (let () (define (f a) - (define-values (dom* rngs* rst) + (define-values (dom* opt-dom* rngs* rst) (match a - [(arr: dom (Values: (list (Result: rngs (LFilterSet: '() '()) (LEmpty:)) ...)) rst #f '()) - (values (map t->c/neg dom) (map t->c rngs) (and rst (t->c/neg rst)))] + [(arr: dom (Values: (list (Result: rngs (LFilterSet: '() '()) (LEmpty:)) ...)) rst #f kws) + (let-values ([(mand-kws opt-kws) (partition (match-lambda [(Keyword: _ _ mand?) mand?]) kws)] + [(conv) (match-lambda [(Keyword: kw kty _) (list kw (t->c/neg kty))])]) + (values (append (map t->c/neg dom) (append-map conv mand-kws)) + (append-map conv opt-kws) + (map t->c rngs) + (and rst (t->c/neg rst))))] [(arr: dom (Values: (list (Result: rngs _ _) ...)) rst #f '()) (if (and out? pos?) - (values (map t->c/neg dom) (map t->c rngs) (and rst (t->c/neg rst))) + (values (map t->c/neg dom) + null + (map t->c rngs) + (and rst (t->c/neg rst))) (exit (fail)))] [_ (exit (fail))])) (trace f) (with-syntax ([(dom* ...) dom*] + [(opt-dom* ...) opt-dom*] [rng* (match rngs* [(list r) r] [_ #`(values #,@rngs*)])] [rst* rst]) - (if rst - #'((dom* ...) () #:rest (listof rst*) . ->* . rng*) - #'(dom* ... . -> . rng*)))) + (if (or rst (pair? (syntax-e #'(opt-dom* ...)))) + #'((dom* ...) (opt-dom* ...) #:rest (listof rst*) . ->* . rng*) + #'(dom* ... . -> . rng*)))) (unless (no-duplicates (for/list ([t arrs]) (match t [(arr: dom _ _ _ _) (length dom)]))) (exit (fail))) diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index a23d9c7532..2e28f10a80 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -283,7 +283,7 @@ ;; pos-flds : (Listof Type) ;; name-flds : (Listof (Tuple Symbol Type Boolean)) ;; methods : (Listof (Tuple Symbol Function)) -(dt Class ([pos-flds (listof Type/c)] +(dt Class ([pos-flds (listof Type/c)] [name-flds (listof (list/c symbol? Type/c boolean?))] [methods (listof (list/c symbol? Function?))]) [#:frees (combine-frees diff --git a/collects/typed-scheme/typecheck/tc-metafunctions.ss b/collects/typed-scheme/typecheck/tc-metafunctions.ss index 2d70375671..716faeccbf 100644 --- a/collects/typed-scheme/typecheck/tc-metafunctions.ss +++ b/collects/typed-scheme/typecheck/tc-metafunctions.ss @@ -147,12 +147,11 @@ ;; and [((FilterSet: f1+ f1-) (FilterSet: f2+ f2-) (F-FS:)) (mk (combine (append f1+ f2+) - null - #; + null (append (for/list ([f f1-]) - (make-ImpFilter f2+ f)) + (make-ImpFilter f2+ (list f))) (for/list ([f f2-]) - (make-ImpFilter f1+ f)))))] + (make-ImpFilter f1+ (list f))))))] [(f f* f*) (mk f*)] [(_ _ _) ;; could intersect f2 and f3 here diff --git a/collects/unstable/contract.ss b/collects/unstable/contract.ss index a7b22b9c50..f3d7d286c1 100644 --- a/collects/unstable/contract.ss +++ b/collects/unstable/contract.ss @@ -1,4 +1,5 @@ -#lang scheme +#lang scheme/base +(require scheme/contract) (define path-element? (or/c path-string? (symbols 'up 'same))) @@ -13,7 +14,45 @@ ;; Eli: If this gets in, there should also be versions for bytes, lists, and ;; vectors. +;; ryanc added: + +;; (if/c predicate then/c else/c) applies then/c to satisfying +;; predicate, else/c to those that don't. +(define (if/c predicate then/c else/c) + #| + Naive version: + (or/c (and/c predicate then/c) + (and/c (not/c predicate) else/c)) + But that applies predicate twice. + |# + (let ([then-ctc (coerce-contract 'if/c then/c)] + [else-ctc (coerce-contract 'if/c else/c)]) + (define name (build-compound-type-name 'if/c predicate then-ctc else-ctc)) + ;; Special case: if both flat contracts, make a flat contract. + (if (and (flat-contract? then-ctc) + (flat-contract? else-ctc)) + ;; flat contract + (let ([then-pred (flat-contract-predicate then-ctc)] + [else-pred (flat-contract-predicate else-ctc)]) + (define (pred x) + (if (predicate x) (then-pred x) (else-pred x))) + (flat-named-contract name pred)) + ;; ho contract + (let ([then-proj ((proj-get then-ctc) then-ctc)] + [then-fo ((first-order-get then-ctc) then-ctc)] + [else-proj ((proj-get else-ctc) else-ctc)] + [else-fo ((first-order-get else-ctc) else-ctc)]) + (define ((proj pos neg srcinfo name pos?) x) + (if (predicate x) + ((then-proj pos neg srcinfo name pos?) x) + ((else-proj pos neg srcinfo name pos?) x))) + (make-proj-contract + name + proj + (lambda (x) (if (predicate x) (then-fo x) (else-fo x)))))))) + (provide/contract [non-empty-string/c contract?] [path-element? contract?] - [port-number? contract?]) + [port-number? contract?] + [if/c (-> procedure? contract? contract? contract?)]) diff --git a/collects/unstable/list.ss b/collects/unstable/list.ss index 697f100c98..661721467a 100644 --- a/collects/unstable/list.ss +++ b/collects/unstable/list.ss @@ -1,19 +1,15 @@ -#lang scheme +#lang scheme/base +(require scheme/contract + scheme/dict) -; list-prefix : list? list? -> (or/c list? false/c) -; Is l a prefix or r?, and what is that prefix? +; list-prefix : list? list? -> boolean? +; Is l a prefix or r? (define (list-prefix? ls rs) - (match ls - [(list) - #t] - [(list-rest l0 ls) - (match rs - [(list) - #f] - [(list-rest r0 rs) - (if (equal? l0 r0) - (list-prefix? ls rs) - #f)])])) + (or (null? ls) + (and (pair? rs) + (equal? (car ls) (car rs)) + (list-prefix? (cdr ls) (cdr rs))))) + ;; Eli: Is this some `match' obsession syndrom? The simple definition: ;; (define (list-prefix? ls rs) ;; (or (null? ls) (and (pair? rs) (equal? (car ls) (car rs)) @@ -25,6 +21,7 @@ ;; (Which can be useful for things like making a path relative to ;; another path.) A nice generalization is to make it get two or more ;; lists, and return a matching number of values. +;; ryanc: changed to use Eli's version (provide/contract [list-prefix? (list? list? . -> . boolean?)]) @@ -38,4 +35,52 @@ (define (extend s t extra) (append t (build-list (- (length s) (length t)) (lambda _ extra)))) -(provide filter-multiple extend) \ No newline at end of file +(provide filter-multiple extend) + +;; ryanc added: + +(provide/contract + [check-duplicate + (->* (list?) + (#:key (-> any/c any/c) + #:same? (or/c dict? (-> any/c any/c any/c))) + any)]) + +;; check-duplicate : (listof X) +;; #:key (X -> K) +;; #:same? (or/c (K K -> bool) dict?) +;; -> X or #f +(define (check-duplicate items + #:key [key values] + #:same? [same? equal?]) + (cond [(procedure? same?) + (cond [(eq? same? equal?) + (check-duplicate/t items key (make-hash) #t)] + [(eq? same? eq?) + (check-duplicate/t items key (make-hasheq) #t)] + [(eq? same? eqv?) + (check-duplicate/t items key (make-hasheqv) #t)] + [else + (check-duplicate/list items key same?)])] + [(dict? same?) + (let ([dict same?]) + (if (dict-mutable? dict) + (check-duplicate/t items key dict #t) + (check-duplicate/t items key dict #f)))])) +(define (check-duplicate/t items key table mutating?) + (let loop ([items items] [table table]) + (and (pair? items) + (let ([key-item (key (car items))]) + (if (dict-ref table key-item #f) + (car items) + (loop (cdr items) (if mutating? + (begin (dict-set! table key-item #t) table) + (dict-set table key-item #t)))))))) +(define (check-duplicate/list items key same?) + (let loop ([items items] [sofar null]) + (and (pair? items) + (let ([key-item (key (car items))]) + (if (for/or ([prev (in-list sofar)]) + (same? key-item prev)) + (car items) + (loop (cdr items) (cons key-item sofar))))))) diff --git a/collects/unstable/mutated-vars.ss b/collects/unstable/mutated-vars.ss index efa9b39e49..a585a2c321 100644 --- a/collects/unstable/mutated-vars.ss +++ b/collects/unstable/mutated-vars.ss @@ -13,8 +13,7 @@ ;; syntax -> void (define (fmv/list lstx) (for-each find-mutated-vars (syntax->list lstx))) - ;(when (and (pair? (syntax->datum form))) (printf "called with ~a~n" (syntax->datum form))) - (kernel-syntax-case* form #f (define-type-alias-internal define-typed-struct-internal require/typed-internal) + (kernel-syntax-case* form #f () ;; what we care about: set! [(set! v e) (begin @@ -51,5 +50,8 @@ ;; less general. ;; - What's with the typed-scheme literals? If they were needed, then ;; typed-scheme is probably broken now. +;; ryanc: +;; - The for-template is needed. +;; - I've removed the bogus literals. (provide find-mutated-vars is-var-mutated?) diff --git a/collects/unstable/scribblings/contract.scrbl b/collects/unstable/scribblings/contract.scrbl index b7851a4629..a774deb59b 100644 --- a/collects/unstable/scribblings/contract.scrbl +++ b/collects/unstable/scribblings/contract.scrbl @@ -1,6 +1,7 @@ #lang scribble/doc @(require scribble/base scribble/manual + "utils.ss" (for-label unstable/contract scheme/contract scheme/base)) @@ -9,8 +10,39 @@ @defmodule[unstable/contract] -@defthing[non-empty-string/c contract?]{Contract for non-empty strings.} +@defthing[non-empty-string/c contract?]{ +Contract for non-empty strings. +} -@defthing[port-number? contract?]{Equivalent to @scheme[(between/c 1 65535)].} +@defthing[port-number? contract?]{ +Equivalent to @scheme[(between/c 1 65535)]. +} -@defthing[path-element? contract?]{Equivalent to @scheme[(or/c path-string? (symbols 'up 'same))].} +@defthing[path-element? contract?]{ +Equivalent to @scheme[(or/c path-string? (symbols 'up 'same))]. +} + +@addition{Ryan Culpepper} + +@defproc[(if/c [predicate (-> any/c any/c)] + [then-contract contract?] + [else-contract contract?]) + contract?]{ + +Produces a contract that, when applied to a value, first tests the +value with @scheme[predicate]; if @scheme[predicate] returns true, the +@scheme[then-contract] is applied; otherwise, the +@scheme[else-contract] is applied. The resulting contract is a flat +contract if both @scheme[then-contract] and @scheme[else-contract] are +flat contracts. + +For example, the following contract enforces that if a value is a +procedure, it is a thunk; otherwise it can be any (non-procedure) +value: + @schemeblock[(if/c procedure? (-> any) any/c)] +Note that the following contract is @bold{not} equivalent: + @schemeblock[(or/c (-> any) any/c) (code:comment "wrong!")] +The last contract is the same as @scheme[any/c] because +@scheme[or/c] tries flat contracts before higher-order contracts. + +} diff --git a/collects/unstable/scribblings/list.scrbl b/collects/unstable/scribblings/list.scrbl index ac5f7bf9ed..aedc04c1b5 100644 --- a/collects/unstable/scribblings/list.scrbl +++ b/collects/unstable/scribblings/list.scrbl @@ -3,9 +3,11 @@ scribble/manual scribble/eval "utils.ss" - (for-label unstable/list - scheme/contract - scheme/base)) + (for-label scheme/dict + unstable/list + syntax/id-table + scheme/contract + scheme/base)) @(define the-eval (make-base-eval)) @(the-eval '(require unstable/list)) @@ -40,4 +42,38 @@ Extends @scheme[l2] to be as long as @scheme[l1] by adding @scheme[(- @examples[#:eval the-eval] (extend '(1 2 3) '(a) 'b) -} \ No newline at end of file +} + + +@addition{Ryan Culpepper} + +@defproc[(check-duplicate [lst list?] + [#:key extract-key (-> any/c any/c) (lambda (x) x)] + [#:same? same? + (or/c (any/c any/c . -> . any/c) + dict?) + equal?]) + (or/c any/c #f)]{ + +Returns the first duplicate item in @scheme[lst]. More precisely, it +returns the first @scheme[_x] such that there was a previous +@scheme[_y] where @scheme[(same? (extract-key _x) (extract-key _y))]. + +The @scheme[same?] argument can either be an equivalence predicate +such as @scheme[equal?] or @scheme[eqv?] or a dictionary. In the +latter case, the elements of the list are mapped to @scheme[#t] in the +dictionary until an element is discovered that is already mapped to a +true value. The procedures @scheme[equal?], @scheme[eqv?], and +@scheme[eq?] automatically use a dictionary for speed. + +@(the-eval '(require syntax/id-table scheme/dict)) +@examples[#:eval the-eval +(check-duplicate '(1 2 3 4)) +(check-duplicate '(1 2 3 2 1)) +(check-duplicate '((a 1) (b 2) (a 3)) #:key car) +(define id-t (make-free-id-table)) +(check-duplicate (syntax->list #'(a b c d a b)) + #:same? id-t) +(dict-map id-t list) +] +} diff --git a/collects/unstable/scribblings/srcloc.scrbl b/collects/unstable/scribblings/srcloc.scrbl new file mode 100644 index 0000000000..f4e69e78c2 --- /dev/null +++ b/collects/unstable/scribblings/srcloc.scrbl @@ -0,0 +1,123 @@ +#lang scribble/manual +@(require scribble/eval "utils.ss" (for-label scheme/base unstable/srcloc)) + +@(define evaluator (make-base-eval)) +@(evaluator '(require unstable/srcloc)) + +@title[#:tag "srcloc"]{Source Locations} + +@defmodule[unstable/srcloc] + +@unstable[@author+email["Carl Eastlund" "cce@ccs.neu.edu"]] + +This module defines utilities for manipulating representations of source +locations, including both @scheme[srcloc] structures and all the values accepted +by @scheme[datum->syntax]'s third argument: syntax objects, lists, vectors, and +@scheme[#f]. + +@deftogether[( +@defproc[(source-location? [x any/c]) boolean?]{} +@defproc[(source-location-list? [x any/c]) boolean?]{} +@defproc[(source-location-vector? [x any/c]) boolean?]{} +)]{ + +These functions recognize valid source location representations. The first, +@scheme[source-location?], recognizes @scheme[srcloc] structures, syntax +objects, lists, and vectors with appropriate structure, as well as @scheme[#f]. +The latter predicates recognize only valid lists and vectors, respectively. + +@examples[#:eval evaluator +(source-location? #f) +(source-location? #'here) +(source-location? (make-srcloc 'here 1 0 1 0)) +(source-location? (make-srcloc 'bad 1 #f 1 0)) +(source-location? (list 'here 1 0 1 0)) +(source-location? (list* 'bad 1 0 1 0 'tail)) +(source-location? (vector 'here 1 0 1 0)) +(source-location? (vector 'bad 0 0 0 0)) +] + +} + +@defproc[(check-source-location! [name symbol?] [x any/c]) void?]{ + +This procedure checks that its input is a valid source location. If it is, the +procedure returns @scheme[(void)]. If it is not, +@scheme[check-source-location!] raises a detailed error message in terms of +@scheme[name] and the problem with @scheme[x]. + +@examples[#:eval evaluator +(check-source-location! 'this-example #f) +(check-source-location! 'this-example #'here) +(check-source-location! 'this-example (make-srcloc 'here 1 0 1 0)) +(check-source-location! 'this-example (make-srcloc 'bad 1 #f 1 0)) +(check-source-location! 'this-example (list 'here 1 0 1 0)) +(check-source-location! 'this-example (list* 'bad 1 0 1 0 'tail)) +(check-source-location! 'this-example (vector 'here 1 0 1 0)) +(check-source-location! 'this-example (vector 'bad 0 0 0 0)) +] + +} + +@deftogether[( +@defproc[(build-source-location [loc source-location?] ...) srcloc?]{} +@defproc[(build-source-location-list [loc source-location?] ...) source-location-list?]{} +@defproc[(build-source-location-vector [loc source-location?] ...) source-location-vector?]{} +@defproc[(build-source-location-syntax [loc source-location?] ...) syntax?]{} +)]{ + +These procedures combine multiple (zero or more) source locations, merging +locations within the same source and reporting @scheme[#f] for locations that +span sources. They also convert the result to the desired representation: +@scheme[srcloc], list, vector, or syntax object, respectively. + +@examples[#:eval evaluator +(build-source-location) +(build-source-location-list) +(build-source-location-vector) +(build-source-location-syntax) +(build-source-location #f) +(build-source-location-list #f) +(build-source-location-vector #f) +(build-source-location-syntax #f) +(build-source-location (list 'here 1 2 3 4)) +(build-source-location-list (make-srcloc 'here 1 2 3 4)) +(build-source-location-vector (make-srcloc 'here 1 2 3 4)) +(build-source-location-syntax (make-srcloc 'here 1 2 3 4)) +(build-source-location (list 'here 1 2 3 4) (vector 'here 5 6 7 8)) +(build-source-location-list (make-srcloc 'here 1 2 3 4) (vector 'here 5 6 7 8)) +(build-source-location-vector (make-srcloc 'here 1 2 3 4) (vector 'here 5 6 7 8)) +(build-source-location-syntax (make-srcloc 'here 1 2 3 4) (vector 'here 5 6 7 8)) +(build-source-location (list 'here 1 2 3 4) (vector 'there 5 6 7 8)) +(build-source-location-list (make-srcloc 'here 1 2 3 4) (vector 'there 5 6 7 8)) +(build-source-location-vector (make-srcloc 'here 1 2 3 4) (vector 'there 5 6 7 8)) +(build-source-location-syntax (make-srcloc 'here 1 2 3 4) (vector 'there 5 6 7 8)) +] + +} + +@deftogether[( +@defproc[(source-location->string [loc source-location?]) string?]{} +@defproc[(source-location->prefix [loc source-location?]) string?]{} +)]{ + +These procedures convert source locations to strings for use in error messages. +The first produces a string describing the source location; the second appends +@scheme[": "] to the string if it is non-empty. + +@examples[#:eval evaluator +(source-location->string (make-srcloc 'here 1 2 3 4)) +(source-location->string (make-srcloc 'here #f #f 3 4)) +(source-location->string (make-srcloc 'here #f #f #f #f)) +(source-location->string (make-srcloc #f 1 2 3 4)) +(source-location->string (make-srcloc #f #f #f 3 4)) +(source-location->string (make-srcloc #f #f #f #f #f)) +(source-location->prefix (make-srcloc 'here 1 2 3 4)) +(source-location->prefix (make-srcloc 'here #f #f 3 4)) +(source-location->prefix (make-srcloc 'here #f #f #f #f)) +(source-location->prefix (make-srcloc #f 1 2 3 4)) +(source-location->prefix (make-srcloc #f #f #f 3 4)) +(source-location->prefix (make-srcloc #f #f #f #f #f)) +] + +} diff --git a/collects/unstable/scribblings/syntax.scrbl b/collects/unstable/scribblings/syntax.scrbl index cca32cc1bb..ac2459fc98 100644 --- a/collects/unstable/scribblings/syntax.scrbl +++ b/collects/unstable/scribblings/syntax.scrbl @@ -88,6 +88,20 @@ expression. @;{----} +@defform[(define/with-syntax pattern expr)]{ + +Definition form of @scheme[with-syntax]. That is, it matches the +syntax object result of @scheme[expr] against @scheme[pattern] and +creates pattern variable definitions for the pattern variables of +@scheme[pattern]. + +@examples[#:eval the-eval +(define/with-syntax (px ...) #'(a b c)) +(define/with-syntax (tmp ...) (generate-temporaries #'(px ...))) +#'([tmp px] ...) +] +} + @defform[(define-pattern-variable id expr)]{ Evaluates @scheme[expr] and binds it to @scheme[id] as a pattern @@ -234,6 +248,50 @@ in the argument list are automatically converted to symbols. the second error but not of the first.) } +@defproc[(internal-definition-context-apply [intdef-ctx internal-definition-context?] + [stx syntax?]) + syntax?]{ + +Applies the renamings of @scheme[intdef-ctx] to @scheme[stx]. + +} + +@defproc[(syntax-local-eval [stx syntax?] + [intdef-ctx (or/c internal-definition-context? #f) #f]) + any]{ + +Evaluates @scheme[stx] as an expression in the current transformer +environment (that is, at phase level 1), optionally extended with +@scheme[intdef-ctx]. + +@examples[#:eval the-eval +(define-syntax (show-me stx) + (syntax-case stx () + [(show-me expr) + (begin + (printf "at compile time produces ~s\n" + (syntax-local-eval #'expr)) + #'(printf "at run time produes ~s\n" + expr))])) +(show-me (+ 2 5)) +(define-for-syntax fruit 'apple) +(define fruit 'pear) +(show-me fruit) +#| +(define-syntax (show-me* stx) + (syntax-case stx () + [(show-me expr1) + (call-with-values (lambda () (syntax-local-eval #'expr1)) + (lambda vals + (with-syntax ([vals vals]) + #'(quote vals))))])) +(define-for-syntax (sum-and-difference a b) + (values (+ a b) (- a b))) +(show-me* (sum-and-difference 12 9)) +|# +] +} + @addition{Sam Tobin-Hochstadt} @defform[(with-syntax* ([pattern stx-expr] ...) diff --git a/collects/unstable/scribblings/unstable.scrbl b/collects/unstable/scribblings/unstable.scrbl index 907a540732..b5eff58733 100644 --- a/collects/unstable/scribblings/unstable.scrbl +++ b/collects/unstable/scribblings/unstable.scrbl @@ -77,6 +77,7 @@ Keep documentation and tests up to date. @include-section["list.scrbl"] @include-section["net.scrbl"] @include-section["path.scrbl"] +@include-section["srcloc.scrbl"] @include-section["string.scrbl"] @include-section["struct.scrbl"] @include-section["syntax.scrbl"] diff --git a/collects/unstable/srcloc.ss b/collects/unstable/srcloc.ss new file mode 100644 index 0000000000..89251f6318 --- /dev/null +++ b/collects/unstable/srcloc.ss @@ -0,0 +1,321 @@ +#lang scheme/base + +;; Unstable library by: Carl Eastlund +;; intended for use in scheme/contract, so don't try to add contracts! + +(provide + + ;; type predicates + source-location? + source-location-list? + source-location-vector? + + ;; error checks + check-source-location! + + ;; conversion and combination + build-source-location + build-source-location-list + build-source-location-vector + build-source-location-syntax + + ;; accessors + source-location-known? + source-location-source + source-location-line + source-location-column + source-location-position + source-location-span + source-location-end + + ;; rendering + source-location->string + source-location->prefix + + ) + +(define (source-location? x) + (process-source-location x good? bad? 'source-location?)) + +(define (source-location-list? x) + (process-list x good? bad? 'source-location-list?)) + +(define (source-location-vector? x) + (process-vector x good? bad? 'source-location-vector?)) + +(define (check-source-location! name x) + (process-source-location x good! bad! name)) + +(define (source-location-known? x) + (process-source-location x good-known? bad! 'source-location-known?)) + +(define (source-location-source x) + (process-source-location x good-source bad! 'source-location-source)) + +(define (source-location-line x) + (process-source-location x good-line bad! 'source-location-line)) + +(define (source-location-position x) + (process-source-location x good-position bad! 'source-location-position)) + +(define (source-location-column x) + (process-source-location x good-column bad! 'source-location-column)) + +(define (source-location-span x) + (process-source-location x good-span bad! 'source-location-span)) + +(define (source-location-end x) + (process-source-location x good-end bad! 'source-location-end)) + +(define (source-location->string x) + (process-source-location x good-string bad! 'source-location->string)) + +(define (source-location->prefix x) + (process-source-location x good-prefix bad! 'source-location->prefix)) + +(define (build-source-location . locs) + (combine-source-locations locs good-srcloc bad! + 'build-source-location)) + +(define (build-source-location-list . locs) + (combine-source-locations locs good-list bad! + 'build-source-location-list)) + +(define (build-source-location-vector . locs) + (combine-source-locations locs good-vector bad! + 'build-source-location-vector)) + +(define (build-source-location-syntax . locs) + (combine-source-locations locs good-syntax bad! + 'build-source-location-syntax)) + +(define (good? x src line col pos span) #t) +(define (bad? fmt . args) #f) + +(define (good! x src line col pos span) (void)) +(define (bad! fmt . args) + (raise + (make-exn:fail:contract + (apply format fmt args) + (current-continuation-marks)))) + +(define (good-known? x src line col pos span) + (and (or src line col pos span) #t)) + +(define (good-source x src line col pos span) src) +(define (good-line x src line col pos span) line) +(define (good-column x src line col pos span) col) +(define (good-position x src line col pos span) pos) +(define (good-span x src line col pos span) span) +(define (good-end x src line col pos span) (and pos span (+ pos span))) + +(define (good-srcloc x src line col pos span) + (if (srcloc? x) x (make-srcloc src line col pos span))) + +(define (good-list x src line col pos span) + (if (list? x) x (list src line col pos span))) + +(define (good-vector x src line col pos span) + (if (vector? x) x (vector src line col pos span))) + +(define (good-syntax x src line col pos span) + (cond + [(syntax? x) x] + [(or (list? x) (vector? x)) (datum->syntax #f null x)] + [else (datum->syntax #f null (vector src line col pos span))])) + +(define (good-string x src line col pos span) + (format "~a~a" + (or src "") + (if line + (if col + (format ":~a.~a" line col) + (format ":~a" line)) + (if pos + (if span + (format "::~a-~a" pos (+ pos span)) + (format "::~a" pos)) + "")))) + +(define (good-prefix x src line col pos span) + (let ([str (good-string x src line col pos span)]) + (if (string=? str "") "" (string-append str ": ")))) + +(define (combine-source-locations locs good bad name) + + (define (loop loc1 src1 line1 col1 pos1 span1 locs) + (if (null? locs) + (good loc1 src1 line1 col1 pos1 span1) + (process-source-location + (car locs) + (lambda (loc2 src2 line2 col2 pos2 span2) + (combine-two + src1 line1 col1 pos1 span1 + src2 line2 col2 pos2 span2 + (lambda (loc src line col pos span) + (loop loc src line col pos span (cdr locs))))) + bad + name))) + + (if (null? locs) + (process-source-location #f good bad name) + (process-source-location + (car locs) + (lambda (loc src line col pos span) + (loop loc src line col pos span (cdr locs))) + bad + name))) + +(define (combine-two src1 line1 col1 pos1 span1 + src2 line2 col2 pos2 span2 + good) + (if (and src1 src2 (equal? src1 src2)) + (let-values + ([(src) src1] + [(line col) + (cond + [(and line1 line2) + (cond + [(< line1 line2) (values line1 col1)] + [(> line1 line2) (values line2 col2)] + [else (values line1 + (if (and col1 col2) + (min col1 col2) + (or col1 col2)))])] + [line1 (values line1 col1)] + [line2 (values line2 col2)] + [else (values #f #f)])] + [(pos span) + (cond + [(and pos1 pos2) + (let ([pos (min pos1 pos2)]) + (cond + [(and span1 span2) + (let ([end (max (+ pos1 span1) (+ pos2 span2))]) + (values pos (- end pos)))] + [span1 (values pos (- (+ pos1 span1) pos))] + [span2 (values pos (- (+ pos2 span2) pos))] + [else (values pos #f)]))])]) + (good #f src line col pos span)) + (good #f #f #f #f #f #f))) + +(define (process-source-location x good bad name) + (cond + ;; #f + [(not x) (process-false x good bad name)] + ;; srcloc + [(srcloc? x) (process-srcloc x good bad name)] + ;; list + [(or (null? x) (pair? x)) (process-list x good bad name)] + ;; vector + [(vector? x) (process-vector x good bad name)] + ;; syntax + [(syntax? x) (process-syntax x good bad name)] + ;; other + [else + (bad + "~a: expected a source location (srcloc struct, syntax object, list, vector, or #f); got: ~e" + name + x)])) + +(define (process-false x good bad name) + (process-elements #f good bad name #f #f #f #f #f)) + +(define (process-srcloc x good bad name) + (process-elements x good bad name + (srcloc-source x) + (srcloc-line x) + (srcloc-column x) + (srcloc-position x) + (srcloc-span x))) + +(define (process-syntax x good bad name) + (process-elements x good bad name + (syntax-source x) + (syntax-line x) + (syntax-column x) + (syntax-position x) + (syntax-span x))) + +(define (process-list x good bad name) + (cond + [(null? x) + (bad + "~a: expected a source location (a list of 5 elements); got an empty list: ~e" + name + x)] + [(list? x) + (let ([n (length x)]) + (if (= n 5) + (apply process-elements x good bad name x) + (bad + "~a: expected a source location (a list of 5 elements); got a list of ~a elements: ~e" + name + n + x)))] + [(pair? x) + (bad + "~a: expected a source location (a list of 5 elements); got an improper list: ~e" + name + x)] + [else + (bad + "~a: expected a source location list; got: ~e" + name + x)])) + +(define (process-vector x good bad name) + (if (vector? x) + (let ([n (vector-length x)]) + (if (= n 5) + (process-elements x good bad name + (vector-ref x 0) + (vector-ref x 1) + (vector-ref x 2) + (vector-ref x 3) + (vector-ref x 4)) + (bad + "~a: expected a source location (a vector of 5 elements); got a vector of ~a elements: ~e" + name + n + x))) + (bad + "~a: expected a source location vector; got: ~e" + name + x))) + +(define (process-elements x good bad name src line col pos span) + (cond + [(and line (not (exact-positive-integer? line))) + (bad + "~a: expected a source location with a positive line number or #f (second element); got line number ~e: ~e" + name + line + x)] + [(and col (not (exact-nonnegative-integer? col))) + (bad + "~a: expected a source location with a non-negative column number or #f (third element); got column number ~e: ~e" + name + col + x)] + [(or (and col (not line)) (and (not col) line)) + (bad + "~a: expected a source location with line number and column number both numeric or both #f; got ~a and ~a respectively: ~e" + name + line + col + x)] + [(and pos (not (exact-positive-integer? pos))) + (bad + "~a: expected a source location with a positive position or #f (fourth element); got line number ~e: ~e" + name + pos + x)] + [(and span (not (exact-nonnegative-integer? span))) + (bad + "~a: expected a source location with a non-negative span or #f (fifth element); got column number ~e: ~e" + name + span + x)] + [else (good x src line col pos span)])) + diff --git a/collects/unstable/struct.ss b/collects/unstable/struct.ss index 1384d643fb..9a272bddad 100644 --- a/collects/unstable/struct.ss +++ b/collects/unstable/struct.ss @@ -3,24 +3,27 @@ (require (for-syntax scheme/base scheme/struct-info)) (provide make - struct->list) + struct->list + (for-syntax get-struct-info)) + +;; get-struct-info : identifier stx -> struct-info-list +(define-for-syntax (get-struct-info id ctx) + (define (bad-struct-name x) + (raise-syntax-error #f "expected struct name" ctx x)) + (unless (identifier? id) + (bad-struct-name id)) + (let ([value (syntax-local-value id (lambda () #f))]) + (unless (struct-info? value) + (bad-struct-name id)) + (extract-struct-info value))) ;; (make struct-name field-expr ...) ;; Checks that correct number of fields given. (define-syntax (make stx) - (define (bad-struct-name x) - (raise-syntax-error #f "expected struct name" stx x)) - (define (get-struct-info id) - (unless (identifier? id) - (bad-struct-name id)) - (let ([value (syntax-local-value id (lambda () #f))]) - (unless (struct-info? value) - (bad-struct-name id)) - (extract-struct-info value))) (syntax-case stx () [(make S expr ...) (let () - (define info (get-struct-info #'S)) + (define info (get-struct-info #'S stx)) (define constructor (list-ref info 1)) (define accessors (list-ref info 3)) (unless (identifier? #'constructor) diff --git a/collects/unstable/syntax.ss b/collects/unstable/syntax.ss index e4f5e4fb6d..0ad94ddeb0 100644 --- a/collects/unstable/syntax.ss +++ b/collects/unstable/syntax.ss @@ -4,11 +4,13 @@ syntax/stx unstable/struct (for-syntax scheme/base - scheme/private/sc)) + scheme/private/sc) + (for-template scheme/base)) (provide unwrap-syntax define-pattern-variable + define/with-syntax with-temporaries generate-temporary @@ -25,7 +27,10 @@ current-syntax-context wrong-syntax - + + internal-definition-context-apply + syntax-local-eval + with-syntax* syntax-map) @@ -182,6 +187,57 @@ extras))) ;; Eli: The `report-error-as' thing seems arbitrary to me. +(define (internal-definition-context-apply intdefs stx) + (let ([qastx (local-expand #`(quote #,stx) 'expression (list #'quote) intdefs)]) + (with-syntax ([(q astx) qastx]) #'astx))) + +(define (syntax-local-eval stx [intdef0 #f]) + (let* ([name (generate-temporary)] + [intdefs (syntax-local-make-definition-context intdef0)]) + (syntax-local-bind-syntaxes (list name) + #`(call-with-values (lambda () #,stx) list) + intdefs) + (internal-definition-context-seal intdefs) + (apply values + (syntax-local-value (internal-definition-context-apply intdefs name) + #f intdefs)))) + +(define-syntax (define/with-syntax stx) + (syntax-case stx () + [(define/with-syntax pattern rhs) + (let* ([pvar-env (get-match-vars #'define/with-syntax + stx + #'pattern + '())] + [depthmap (for/list ([x pvar-env]) + (let loop ([x x] [d 0]) + (if (pair? x) + (loop (car x) (add1 d)) + (cons x d))))] + [pvars (map car depthmap)] + [depths (map cdr depthmap)] + [mark (make-syntax-introducer)]) + (with-syntax ([(pvar ...) pvars] + [(depth ...) depths] + [(valvar ...) (generate-temporaries pvars)]) + #'(begin (define-values (valvar ...) + (with-syntax ([pattern rhs]) + (values (pvar-value pvar) ...))) + (define-syntax pvar + (make-syntax-mapping 'depth (quote-syntax valvar))) + ...)))])) + +;; auxiliary macro +(define-syntax (pvar-value stx) + (syntax-case stx () + [(_ pvar) + (identifier? #'pvar) + (let ([mapping (syntax-local-value #'pvar)]) + (unless (syntax-pattern-variable? mapping) + (raise-syntax-error #f "not a pattern variable" #'pvar)) + (syntax-mapping-valvar mapping))])) + + (define-syntax (with-syntax* stx) (syntax-case stx () [(_ (cl) body ...) #'(with-syntax (cl) body ...)] @@ -189,4 +245,4 @@ #'(with-syntax (cl) (with-syntax* (cls ...) body ...))])) (define (syntax-map f . stxls) - (apply map f (map syntax->list stxls))) \ No newline at end of file + (apply map f (map syntax->list stxls))) diff --git a/collects/web-server/scribblings/tutorial/continue.scrbl b/collects/web-server/scribblings/tutorial/continue.scrbl index b366eb8322..263236034a 100644 --- a/collects/web-server/scribblings/tutorial/continue.scrbl +++ b/collects/web-server/scribblings/tutorial/continue.scrbl @@ -100,7 +100,7 @@ responses. One basic kind of response is to show an HTML page. For example: -The HTML @tt{hello} is represented as @scheme["hello"]. +The HTML @tt{hello} is represented as @scheme["hello"]. Strings are automatically escaped when output. This guarantees valid HTML. Therefore, the value @scheme["Unfinished tag"] is rendered as @tt{<b>Unfinished tag} not @tt{Unfinished tag}. Similarly, @scheme["Finished tag"] is rendered as @tt{<i>Finished tag</i>} not @tt{Finished tag}. @tt{

This is an example

} is diff --git a/doc/release-notes/mzscheme/HISTORY.txt b/doc/release-notes/mzscheme/HISTORY.txt index 1c35a4436d..ae7d173969 100644 --- a/doc/release-notes/mzscheme/HISTORY.txt +++ b/doc/release-notes/mzscheme/HISTORY.txt @@ -1,3 +1,10 @@ +Version 4.2.3.4 +Added flvectors + +Version 4.2.3.3 +Added unsafe-f64vector-ref and unsafe-f64vector-set! +Changed JIT to inline numeric ops with more than 2 arguments + Version 4.2.3, November 2009 Changed _pointer (in scheme/foreign) to mean a pointer that does not refer to GCable memory; added _gcpointer diff --git a/src/mzscheme/cmdline.inc b/src/mzscheme/cmdline.inc index 9194656ae0..ef5510a7af 100644 --- a/src/mzscheme/cmdline.inc +++ b/src/mzscheme/cmdline.inc @@ -456,7 +456,9 @@ static int run_from_cmd_line(int argc, char *_argv[], GC_CAN_IGNORE char **argv = _argv; Scheme_Env *global_env; char *prog, *sprog = NULL; - Scheme_Object *sch_argv, *collects_path = NULL, *collects_extra = NULL; + Scheme_Object *sch_argv, + *collects_path = NULL, *collects_extra = NULL, + *addon_dir = NULL; int i; #ifndef DONT_PARSE_COMMAND_LINE char **evals_and_loads, *real_switch = NULL, specific_switch[2]; @@ -681,8 +683,6 @@ static int run_from_cmd_line(int argc, char *_argv[], argv[0] = "-j"; else if (!strcmp("--no-delay", argv[0])) argv[0] = "-d"; - else if (!strcmp("--no-argv", argv[0])) - argv[0] = "-A"; else if (!strcmp("--repl", argv[0])) argv[0] = "-i"; else if (!strcmp("--binary", argv[0])) @@ -695,6 +695,8 @@ static int run_from_cmd_line(int argc, char *_argv[], argv[0] = "-X"; else if (!strcmp("--search", argv[0])) argv[0] = "-S"; + else if (!strcmp("--addon", argv[0])) + argv[0] = "-A"; # ifdef CMDLINE_STDIO_FLAG else if (!strcmp("--stdio", argv[0])) argv[0] = "-z"; @@ -740,6 +742,17 @@ static int run_from_cmd_line(int argc, char *_argv[], collects_path = scheme_make_path(argv[0]); was_config_flag = 1; break; + case 'A': + if (argc < 2) { + PRINTF("%s: missing path after %s switch\n", + prog, real_switch); + goto show_need_help; + } + argv++; + --argc; + addon_dir = scheme_make_path(argv[0]); + was_config_flag = 1; + break; case 'U': scheme_set_ignore_user_paths(1); was_config_flag = 1; @@ -981,7 +994,7 @@ static int run_from_cmd_line(int argc, char *_argv[], #endif ) #endif - PRINTF(BANNER); + PRINTF("%s", BANNER); #ifdef MZSCHEME_CMD_LINE # ifdef DOS_FILE_SYSTEM # if !defined(FILES_HAVE_FDS) @@ -1043,6 +1056,20 @@ static int run_from_cmd_line(int argc, char *_argv[], } #ifndef NO_FILE_SYSTEM_UTILS + /* Setup path for "addon" directory: */ + { +#ifdef GETENV_FUNCTION + if (!addon_dir) { + char *s; + s = getenv("PLTADDONDIR"); + if (s) { + s = scheme_expand_filename(s, -1, NULL, NULL, 0); + if (s) addon_dir = scheme_make_path(s); + } + } +#endif + if (addon_dir) scheme_set_addon_dir(addon_dir); + } /* Setup path for "collects" collection directory: */ { Scheme_Object *l, *r; @@ -1151,6 +1178,7 @@ static int run_from_cmd_line(int argc, char *_argv[], " -I : Set to \n" " -X , --collects : Main collects at \n" " -S , --search : More collects at (after main collects)\n" + " -A , --addon : Addon directory at \n" " -U, --no-user-path : Ignore user-specific collects, etc.\n" " -N , --name : Sets `(find-system-path 'run-file)' to \n" # ifdef MZ_USE_JIT diff --git a/src/mzscheme/gc2/gc2.h b/src/mzscheme/gc2/gc2.h index 8e7f14b69c..6df25495b4 100644 --- a/src/mzscheme/gc2/gc2.h +++ b/src/mzscheme/gc2/gc2.h @@ -1,4 +1,3 @@ - #ifndef __mzscheme_gc_2__ #define __mzscheme_gc_2__ @@ -419,6 +418,16 @@ GC2_EXTERN unsigned long GC_make_jit_nursery_page(); with the next GC. */ +GC2_EXTERN void GC_check_master_gc_request(); +/* + Checks to see if the master has requested a places major GC run + and executes a GC if requested +*/ + +GC2_EXTERN void GC_set_put_external_event_fd(void *fd); +/* + Sets the fd that can be passed to scheme_signal_received_at to wake up the place for GC +*/ # ifdef __cplusplus }; diff --git a/src/mzscheme/gc2/newgc.c b/src/mzscheme/gc2/newgc.c index bd6eda90c3..1999ea4e97 100644 --- a/src/mzscheme/gc2/newgc.c +++ b/src/mzscheme/gc2/newgc.c @@ -58,6 +58,12 @@ # define GC_ASSERT(x) /* empty */ #endif +#if 0 +# define GC_LOCK_DEBUG(args) printf(args) +#else +# define GC_LOCK_DEBUG(args) /* empty */ +#endif + /* the page type constants */ enum { PAGE_TAGGED = 0, @@ -70,6 +76,12 @@ enum { PAGE_TYPES = 6, }; +enum { + SIZE_CLASS_MED_PAGE = 1, + SIZE_CLASS_BIG_PAGE = 2, + SIZE_CLASS_BIG_PAGE_MARKED = 3, +}; + static const char *type_name[PAGE_TYPES] = { "tagged", "atomic", @@ -81,21 +93,53 @@ static const char *type_name[PAGE_TYPES] = { #include "newgc.h" + #ifdef MZ_USE_PLACES static NewGC *MASTERGC; static NewGCMasterInfo *MASTERGCINFO; THREAD_LOCAL_DECL(static objhead GC_objhead_template); +inline static int premaster_or_master_gc(NewGC *gc) { + return (!MASTERGC || gc == MASTERGC); +} +inline static int premaster_or_place_gc(NewGC *gc) { + return (!MASTERGC || gc != MASTERGC); +} +inline static int postmaster_and_master_gc(NewGC *gc) { + return (MASTERGC && gc == MASTERGC); +} +inline static int postmaster_and_place_gc(NewGC *gc) { + return (MASTERGC && gc != MASTERGC); +} +static FILE *GCVERBOSEFH; +static FILE* gcdebugOUT() { + if (GCVERBOSEFH) { fflush(GCVERBOSEFH); } + else { GCVERBOSEFH = fopen("GCDEBUGOUT", "w"); } + return GCVERBOSEFH; +} + +inline static size_t real_page_size(mpage* page); +#ifdef DEBUG_GC_PAGES +static void GCVERBOSEPAGE(const char *msg, mpage* page) { + fprintf(gcdebugOUT(), "%s %p %p %p\n", msg, page, page->addr, (void*)((long)page->addr + real_page_size(page))); +} +#else +#define GCVERBOSEPAGE(msg, page) /* EMPTY */ #endif + +/* #define KILLING_DEBUG */ +#ifdef KILLING_DEBUG +static void killing_debug(NewGC *gc, void *info); +static void marking_rmp_debug(NewGC *gc, void *info); +#endif +#else +#define GCVERBOSEPAGE(msg, page) /* EMPTY */ +#endif + THREAD_LOCAL_DECL(static NewGC *GC); #define GCTYPE NewGC #define GC_get_GC() (GC) #define GC_set_GC(gc) (GC = gc) -#ifdef MZ_USE_PLACES -inline static int is_master_gc(NewGC *gc) { - return (MASTERGC == gc); -} -#endif #include "msgprint.c" @@ -538,7 +582,30 @@ static inline void* REMOVE_BIG_PAGE_PTR_TAG(void *p) { return ((void *)((~((unsigned long) 1)) & ((unsigned long) p))); } +void GC_check_master_gc_request() { +#ifdef MZ_USE_PLACES + if (MASTERGC && MASTERGC->major_places_gc == 1 && MASTERGCINFO->have_collected[GC_objhead_template.owner] != 0) { + GC_gcollect(); + } +#endif +} +static inline void gc_if_needed_account_alloc_size(NewGC *gc, size_t allocate_size) { + if((gc->gen0.current_size + allocate_size) >= gc->gen0.max_size) { +#ifdef MZ_USE_PLACES + if (postmaster_and_master_gc(gc)) { + MASTERGC->major_places_gc = 1; + } + else { +#endif + if (!gc->dumping_avoid_collection) + garbage_collect(gc, 0); +#ifdef MZ_USE_PLACES + } +#endif + } + gc->gen0.current_size += allocate_size; +} /* the core allocation functions */ static void *allocate_big(const size_t request_size_bytes, int type) @@ -550,6 +617,9 @@ static void *allocate_big(const size_t request_size_bytes, int type) #ifdef NEWGC_BTC_ACCOUNT if(GC_out_of_memory) { +#ifdef MZ_USE_PLACES + if (premaster_or_place_gc(gc)) { +#endif if (BTC_single_allocation_limit(gc, request_size_bytes)) { /* We're allowed to fail. Check for allocations that exceed a single-time limit. Otherwise, the limit doesn't work as intended, because @@ -560,6 +630,9 @@ static void *allocate_big(const size_t request_size_bytes, int type) is independent of any existing object, then we can enforce the limit. */ GC_out_of_memory(); } +#ifdef MZ_USE_PLACES + } +#endif } #endif @@ -569,10 +642,7 @@ static void *allocate_big(const size_t request_size_bytes, int type) aligned for Sparcs. */ allocate_size = COMPUTE_ALLOC_SIZE_FOR_BIG_PAGE_SIZE(request_size_bytes); - if((gc->gen0.current_size + allocate_size) >= gc->gen0.max_size) { - if (!gc->dumping_avoid_collection) - garbage_collect(gc, 0); - } + gc_if_needed_account_alloc_size(gc, allocate_size); /* The following allocations may fail and escape if GC_out_of_memory is set. We not only need APAGE_SIZE alignment, we @@ -590,6 +660,7 @@ static void *allocate_big(const size_t request_size_bytes, int type) bpage->size = allocate_size; bpage->size_class = 2; bpage->page_type = type; + GCVERBOSEPAGE("NEW BIG PAGE", bpage); #ifdef MZ_USE_PLACES memcpy(BIG_PAGE_TO_OBJHEAD(bpage), &GC_objhead_template, sizeof(objhead)); @@ -619,6 +690,7 @@ inline static mpage *create_new_medium_page(NewGC *gc, const int sz, const int p page->page_type = PAGE_BIG; page->previous_size = PREFIX_SIZE; page->live_size = sz; + GCVERBOSEPAGE("NEW MED PAGE", page); for (n = page->previous_size; ((n + sz) <= APAGE_SIZE); n += sz) { objhead *info = (objhead *)PTR(NUM(page->addr) + n); @@ -663,6 +735,29 @@ inline static void *medium_page_realloc_dead_slot(NewGC *gc, const int sz, const } return 0; } +#if defined(linux) +/* #define MASTER_ALLOC_DEBUG */ +#if defined(MASTER_ALLOC_DEBUG) +#include +#include +#include + +/* Obtain a backtrace and print it to stdout. */ +void print_libc_backtrace (FILE *file) +{ + void *array[100]; + size_t size; + char **strings; + size_t i; + + size = backtrace (array, 100); + strings = backtrace_symbols (array, size); + for (i = 0; i < size; i++) + fprintf(file, "%s\n", strings[i]); + free (strings); +} +#endif +#endif static void *allocate_medium(const size_t request_size_bytes, const int type) { @@ -683,7 +778,11 @@ static void *allocate_medium(const size_t request_size_bytes, const int type) { NewGC *gc = GC_get_GC(); - void * objptr = medium_page_realloc_dead_slot(gc, sz, pos, type); + void *objptr; + + /* gc_if_needed_account_alloc_size(gc, sz); */ + + objptr = medium_page_realloc_dead_slot(gc, sz, pos, type); if (!objptr) { mpage *page; objhead *info; @@ -696,6 +795,13 @@ static void *allocate_medium(const size_t request_size_bytes, const int type) objptr = OBJHEAD_TO_OBJPTR(info); } +#ifdef MASTER_ALLOC_DEBUG + if (postmaster_and_master_gc(gc)) { + fprintf(gcdebugOUT(), "MASTERGC_allocate_medium %zi %i %i %i %i %p\n", request_size_bytes, type, sz, pos, 1 << (pos +3), objptr); + /* print_libc_backtrace(gcdebugOUT()); */ + } +#endif + ASSERT_VALID_OBJPTR(objptr); return objptr; } @@ -709,6 +815,7 @@ inline static mpage *gen0_create_new_nursery_mpage(NewGC *gc, const size_t page_ newmpage->size_class = 0; newmpage->size = PREFIX_SIZE; pagemap_add_with_size(gc->page_maps, newmpage, page_size); + GCVERBOSEPAGE("NEW gen0", newmpage); return newmpage; } @@ -794,6 +901,11 @@ inline static void *allocate(const size_t request_size, const int type) while (OVERFLOWS_GEN0(newptr)) { NewGC *gc = GC_get_GC(); +#ifdef MZ_USE_PLACES + if (postmaster_and_master_gc(gc)) { + return allocate_medium(request_size, type); + } +#endif /* bring page size used up to date */ gc->gen0.curr_alloc_page->size = GC_gen0_alloc_page_ptr - NUM(gc->gen0.curr_alloc_page->addr); gc->gen0.current_size += gc->gen0.curr_alloc_page->size; @@ -852,7 +964,9 @@ inline static void *allocate(const size_t request_size, const int type) info->type = type; info->size = BYTES_MULTIPLE_OF_WORD_TO_WORDS(allocate_size); /* ALIGN_BYTES_SIZE bumbed us up to the next word boundary */ { + /* NewGC *gc = GC_get_GC(); */ void * objptr = OBJHEAD_TO_OBJPTR(info); + /* fprintf(gcdebugOUT(), "ALLOCATE page %p %zi %i %p\n", gc->gen0.curr_alloc_page->addr, request_size, type, objptr); */ ASSERT_VALID_OBJPTR(objptr); return objptr; } @@ -1699,6 +1813,10 @@ int GC_merely_accounting() /* administration / initialization */ /*****************************************************************************/ +static inline size_t real_page_size(mpage *page) { + return (page->size_class > 1) ? round_to_apage_size(page->size) : APAGE_SIZE; +} + static int designate_modified_gc(NewGC *gc, void *p) { mpage *page = pagemap_find_page(gc->page_maps, p); @@ -1711,7 +1829,7 @@ static int designate_modified_gc(NewGC *gc, void *p) if(page) { if (!page->back_pointers) { page->mprotected = 0; - vm_protect_pages(page->addr, (page->size_class > 1) ? round_to_apage_size(page->size) : APAGE_SIZE, 1); + vm_protect_pages(page->addr, real_page_size(page), 1); page->back_pointers = 1; } /* For a single mutator thread, we shouldn't get here @@ -1754,11 +1872,76 @@ static void NewGCMasterInfo_cleanup() { MASTERGCINFO = NULL; } +static void NewGCMasterInfo_set_have_collected() { + MASTERGCINFO->have_collected[GC_objhead_template.owner] = 1; +} + +static void Master_collect() { + + NewGC *gc = GC_get_GC(); + if (premaster_or_master_gc(gc)) return; /* master shouldn't attempt to start itself */ + + GC_switch_to_master_gc(); + GC_LOCK_DEBUG("MGCLOCK Master_collect\n"); + + if ( MASTERGC->major_places_gc ) { + int i = 0; + int children_ready = 1; + int maxid = MASTERGCINFO->next_GC_id; + for (i=1; i < maxid; i++) { + int have_collected = MASTERGCINFO->have_collected[i]; + + if (have_collected == 1) { + printf("%i READY\n", i); + } + else if ( have_collected == 0) { + void *signal_fd = MASTERGCINFO->signal_fds[i]; + printf("%i NOT COLLECTED\n", i); + children_ready = 0; + MASTERGCINFO->have_collected[i] = -1; + if (signal_fd >= 0 ) { + scheme_signal_received_at(signal_fd); + } + } + else { + printf("%i SIGNALED BUT NOT COLLECTED\n", i); + } + } + if (children_ready) { + for (i=0; i < maxid; i++) { + MASTERGCINFO->have_collected[i] = 0; + } + printf("START MASTER COLLECTION\n"); + fprintf(gcdebugOUT(), "START MASTER COLLECTION\n"); + MASTERGC->major_places_gc = 0; + garbage_collect(MASTERGC, 1); + printf("END MASTER COLLECTION\n"); + fprintf(gcdebugOUT(), "END MASTER COLLECTION\n"); + } + } + + GC_LOCK_DEBUG("UNMGCLOCK Master_collect\n"); + GC_switch_back_from_master(gc); +} + static void NewGCMasterInfo_get_next_id(NewGC *newgc) { + int newid; /* this could just be an atomic op if we had those */ /* waiting for other threads to finish a possible concurrent GC is not optimal*/ mzrt_rwlock_wrlock(MASTERGCINFO->cangc); - GC_objhead_template.owner = MASTERGCINFO->next_GC_id++; + newid = MASTERGCINFO->next_GC_id++; + GC_objhead_template.owner = newid; + /* printf("ALLOCATED GC OID %li\n", GC_objhead_template.owner); */ + MASTERGCINFO->have_collected = realloc(MASTERGCINFO->have_collected, sizeof(char) * MASTERGCINFO->next_GC_id); + MASTERGCINFO->signal_fds = realloc(MASTERGCINFO->signal_fds, sizeof(void*) * MASTERGCINFO->next_GC_id); + MASTERGCINFO->have_collected[newid] = 0; + MASTERGCINFO->signal_fds[newid] = -1; + mzrt_rwlock_unlock(MASTERGCINFO->cangc); +} + +void GC_set_put_external_event_fd(void *fd) { + mzrt_rwlock_wrlock(MASTERGCINFO->cangc); + MASTERGCINFO->signal_fds[GC_objhead_template.owner] = fd; mzrt_rwlock_unlock(MASTERGCINFO->cangc); } #endif @@ -1882,8 +2065,16 @@ void GC_switch_out_master_gc() { static int initialized = 0; if(!initialized) { + NewGC *gc = GC_get_GC(); initialized = 1; - MASTERGC = GC_get_GC(); + garbage_collect(gc, 1); + +#ifdef MZ_USE_PLACES + GC_gen0_alloc_page_ptr = 2; + GC_gen0_alloc_page_end = 1; +#endif + + MASTERGC = gc; MASTERGC->dumping_avoid_collection = 1; save_globals_to_gc(MASTERGC); GC_construct_child_gc(); @@ -1905,13 +2096,13 @@ void GC_switch_in_master_gc() { void *GC_switch_to_master_gc() { NewGC *gc = GC_get_GC(); /* return if MASTERGC hasn't been constructed yet, allow recursive locking */ - if (!MASTERGC || gc == MASTERGC) { - return MASTERGC; - } + if (premaster_or_master_gc(gc)) { return MASTERGC; } + save_globals_to_gc(gc); /*obtain exclusive access to MASTERGC*/ mzrt_rwlock_wrlock(MASTERGCINFO->cangc); + GC_LOCK_DEBUG("MGCLOCK GC_switch_to_master_gc\n"); GC_set_GC(MASTERGC); restore_globals_from_gc(MASTERGC); @@ -1920,19 +2111,18 @@ void *GC_switch_to_master_gc() { void GC_switch_back_from_master(void *gc) { /* return if MASTERGC hasn't been constructed yet, allow recursive locking */ - if (!MASTERGC || gc == MASTERGC) { - return; - } + if (premaster_or_master_gc(gc)) { return; } save_globals_to_gc(MASTERGC); /*release exclusive access to MASTERGC*/ + GC_LOCK_DEBUG("UNMGCLOCK GC_switch_to_master_gc\n"); mzrt_rwlock_unlock(MASTERGCINFO->cangc); GC_set_GC(gc); restore_globals_from_gc(gc); } - + #endif void GC_gcollect(void) @@ -1995,8 +2185,13 @@ void GC_mark(const void *const_p) gc = GC_get_GC(); if(!(page = pagemap_find_page(gc->page_maps, p))) { - GCDEBUG((DEBUGOUTF,"Not marking %p (no page)\n",p)); - return; +#ifdef MZ_USE_PLACES + if (!MASTERGC || !(page = pagemap_find_page(MASTERGC->page_maps, p))) +#endif + { + GCDEBUG((DEBUGOUTF,"Not marking %p (no page)\n",p)); + return; + } } /* toss this over to the BTC mark routine if we're doing accounting */ @@ -2191,6 +2386,11 @@ static inline void propagate_marks_worker(PageMap pagemap, Mark_Proc *mark_table mpage *page; p = REMOVE_BIG_PAGE_PTR_TAG(pp); page = pagemap_find_page(pagemap, p); +#ifdef MZ_USE_PLACES + if (!page) { + page = pagemap_find_page(MASTERGC->page_maps, p); + } +#endif start = PPTR(BIG_PAGE_TO_OBJECT(page)); alloc_type = page->page_type; end = PAGE_END_VSS(page); @@ -2526,9 +2726,7 @@ static void reset_gen1_page(NewGC *gc, mpage *work) { if (gc->generations_available && work->mprotected) { work->mprotected = 0; - add_protect_page_range(gc->protect_range, work->addr, - (work->size_class > 1) ? round_to_apage_size(work->size) : APAGE_SIZE, - APAGE_SIZE, 1); + add_protect_page_range(gc->protect_range, work->addr, real_page_size(work), APAGE_SIZE, 1); } } @@ -2564,9 +2762,7 @@ static void remove_gen1_page_from_pagemap(NewGC *gc, mpage *work) { if (gc->generations_available && work->back_pointers && work->mprotected) { work->mprotected = 0; - add_protect_page_range(gc->protect_range, work->addr, - (work->size_class > 1) ? round_to_apage_size(work->size) : APAGE_SIZE, - APAGE_SIZE, 1); + add_protect_page_range(gc->protect_range, work->addr, real_page_size(work), APAGE_SIZE, 1); } pagemap_remove(gc->page_maps, work); work->added = 0; @@ -2685,6 +2881,7 @@ mpage *allocate_compact_target(NewGC *gc, mpage *work) npage->page_type = work->page_type; npage->marked_on = 1; backtrace_new_page(gc, npage); + GCVERBOSEPAGE("NEW COMPACT PAGE", npage); /* Link in this new replacement page */ npage->prev = work; npage->next = work->next; @@ -2790,22 +2987,84 @@ inline static void do_heap_compact(NewGC *gc) } } +#ifdef KILLING_DEBUG +#include +static void fprintf_buffer(FILE* file, char* buf, int l) { + int i; + for (i=0; i < l; i++ ) { fprintf(file, "%02hhx",buf[i]); } + fprintf(file, "\n"); + for (i=0; i < l; i++ ) { + unsigned char c = buf[i]; + if(isprint(c)) { fprintf(file, "%c ", c); } + else { fprintf(file, " "); } + } + fprintf(file, "\n"); +} + +static void fprintf_debug(NewGC *gc, const char *msg, objhead *info, FILE* file, int isgc) { + if (!isgc || postmaster_and_master_gc(gc)) { + Scheme_Object *obj = OBJHEAD_TO_OBJPTR(info); + fprintf(file, "%s %p ot %i it %i im %i is %i is >> 3 %i\n", msg, obj, obj->type, info->type, info->mark, info->size, info->size >> 3); + switch (obj->type) { + case scheme_unix_path_type: + if (pagemap_find_page(gc->page_maps, SCHEME_PATH_VAL(obj))) { + fprintf_buffer(file, SCHEME_PATH_VAL(obj), SCHEME_PATH_LEN(obj)); + } + else { + fprintf(file, "%p already freed and out of bounds\n", SCHEME_PATH_VAL(obj)); + } + break; + case scheme_symbol_type: + fprintf_buffer(file, SCHEME_SYM_VAL(obj), SCHEME_SYM_LEN(obj)); + break; + case scheme_resolved_module_path_type: + if (pagemap_find_page(gc->page_maps, SCHEME_PTR_VAL(obj))) { + fprintf_debug(gc, "RMP ", OBJPTR_TO_OBJHEAD(SCHEME_PTR_VAL(obj)), file, isgc); + } + else { + fprintf(file, "RMP %p already freed and out of bounds\n", SCHEME_PATH_VAL(obj)); + } + default: + fprintf_buffer(file, ((char *)obj), (info->size * WORD_SIZE)); + break; + } + } +} +static void killing_debug(NewGC *gc, void *info) { + fprintf_debug(gc, "killing", (objhead *) info, gcdebugOUT(), 1); +} +static void marking_rmp_debug(NewGC *gc, void *info) { + fprintf_debug(gc, "marking rmp", (objhead *) info, gcdebugOUT(), 0); +} +#endif + static void repair_heap(NewGC *gc) { mpage *page; int i; Fixup_Proc *fixup_table = gc->fixup_table; +#ifdef MZ_USE_PLACES + int master_has_switched = postmaster_and_master_gc(gc); +#endif for(i = 0; i < PAGE_TYPES; i++) { for(page = gc->gen1_pages[i]; page; page = page->next) { - if(page->marked_on) { +#ifdef MZ_USE_PLACES + if (master_has_switched || page->marked_on) { +#else + if (page->marked_on) { +#endif page->has_new = 0; /* these are guaranteed not to be protected */ if(page->size_class) { /* since we get here via gen1_pages, it's a big page */ void **start = PPTR(BIG_PAGE_TO_OBJECT(page)); void **end = PAGE_END_VSS(page); - +#ifdef MZ_USE_PLACES + objhead *info = BIG_PAGE_TO_OBJHEAD(page); + if (page->marked_on || info->mark) { + page->marked_on = 1; +#endif GCDEBUG((DEBUGOUTF, "Cleaning objs on page %p, starting with %p\n", page, start)); page->size_class = 2; /* remove the mark */ @@ -2828,6 +3087,9 @@ static void repair_heap(NewGC *gc) break; } } +#ifdef MZ_USE_PLACES + } +#endif } else { void **start = PPTR(NUM(page->addr) + page->previous_size); void **end = PAGE_END_VSS(page); @@ -2912,7 +3174,11 @@ static void repair_heap(NewGC *gc) for (i = 0; i < NUM_MED_PAGE_SIZES; i++) { for (page = gc->med_pages[i]; page; page = page->next) { +#ifdef MZ_USE_PLACES + if (master_has_switched || page->marked_on) { +#else if (page->marked_on) { +#endif void **start = PPTR(NUM(page->addr) + PREFIX_SIZE); void **end = PPTR(NUM(page->addr) + APAGE_SIZE - page->size); @@ -2936,9 +3202,17 @@ static void repair_heap(NewGC *gc) start += info->size; } break; + case PAGE_ATOMIC: + start += info->size; } info->mark = 0; +#ifdef MZ_USE_PLACES + page->marked_on = 1; +#endif } else { +#ifdef KILLING_DEBUG + killing_debug(gc, info); +#endif info->dead = 1; start += info->size; } @@ -2949,10 +3223,9 @@ static void repair_heap(NewGC *gc) } static inline void gen1_free_mpage(PageMap pagemap, mpage *page) { - size_t real_page_size = (page->size_class > 1) ? round_to_apage_size(page->size) : APAGE_SIZE; pagemap_remove(pagemap, page); free_backtrace(page); - free_pages(GC, page->addr, real_page_size); + free_pages(GC, page->addr, real_page_size(page)); free_mpage(page); } @@ -2963,6 +3236,7 @@ static inline void cleanup_vacated_pages(NewGC *gc) { /* Free pages vacated by compaction: */ while (pages) { mpage *next = pages->next; + GCVERBOSEPAGE("Cleaning up vacated", pages); gen1_free_mpage(pagemap, pages); pages = next; } @@ -2980,6 +3254,9 @@ inline static void gen0_free_big_pages(NewGC *gc) { free_pages(gc, work->addr, round_to_apage_size(work->size)); free_mpage(work); } + + /* They are all gone, set the pointer to NULL */ + gc->gen0.big_pages = NULL; } static void clean_up_heap(NewGC *gc) @@ -3000,6 +3277,7 @@ static void clean_up_heap(NewGC *gc) /* remove work from list */ if(prev) prev->next = next; else gc->gen1_pages[i] = next; if(next) work->next->prev = prev; + GCVERBOSEPAGE("Cleaning up BIGPAGE", work); gen1_free_mpage(pagemap, work); } else { pagemap_add(pagemap, work); @@ -3050,6 +3328,7 @@ static void clean_up_heap(NewGC *gc) /* free the page */ if(prev) prev->next = next; else gc->med_pages[i] = next; if(next) work->next->prev = prev; + GCVERBOSEPAGE("Cleaning up MED PAGE NO OBJ", work); gen1_free_mpage(pagemap, work); } } else if (gc->gc_full || !work->generation) { @@ -3058,6 +3337,7 @@ static void clean_up_heap(NewGC *gc) next = work->next; if(prev) prev->next = next; else gc->med_pages[i] = next; if(next) work->next->prev = prev; + GCVERBOSEPAGE("Cleaning up MED NO MARKEDON", work); gen1_free_mpage(pagemap, work); } else { /* not touched during minor gc */ @@ -3076,6 +3356,34 @@ static void clean_up_heap(NewGC *gc) cleanup_vacated_pages(gc); } +static void unprotect_old_pages(NewGC *gc) +{ + Page_Range *protect_range = gc->protect_range; + mpage *page; + int i; + + for(i = 0; i < PAGE_TYPES; i++) { + if(i != PAGE_ATOMIC) + for(page = gc->gen1_pages[i]; page; page = page->next) + if(page->page_type != PAGE_ATOMIC) { + if (page->mprotected) { + page->mprotected = 0; + add_protect_page_range(protect_range, page->addr, page->size, APAGE_SIZE, 1); + } + } + } + + for (i = 0; i < NUM_MED_PAGE_SIZES; i++) { + for (page = gc->med_pages[i]; page; page = page->next) { + if (page->mprotected) { + page->mprotected = 0; + add_protect_page_range(protect_range, page->addr, page->size, APAGE_SIZE, 1); + } + } + } + + flush_protect_page_ranges(protect_range, 0); +} static void protect_old_pages(NewGC *gc) { Page_Range *protect_range = gc->protect_range; @@ -3126,9 +3434,21 @@ extern double scheme_get_inexact_milliseconds(void); static void garbage_collect(NewGC *gc, int force_full) { - unsigned long old_mem_use = gc->memory_in_use; - unsigned long old_gen0 = gc->gen0.current_size; + unsigned long old_mem_use; + unsigned long old_gen0; + int next_gc_full; + +#ifdef MZ_USE_PLACES + if (postmaster_and_place_gc(gc)) { + mzrt_rwlock_rdlock(MASTERGCINFO->cangc); + /* printf("RD MGCLOCK garbage_collect %i\n", GC_objhead_template.owner); */ + } +#endif + + old_mem_use = gc->memory_in_use; + old_gen0 = gc->gen0.current_size; + TIME_DECLS(); /* determine if this should be a full collection or not */ @@ -3190,7 +3510,7 @@ static void garbage_collect(NewGC *gc, int force_full) mark_immobiles(gc); TIME_STEP("rooted"); #ifdef MZ_USE_PLACES - if (!is_master_gc(gc)) + if (premaster_or_place_gc(gc)) #endif GC_mark_variable_stack(GC_variable_stack, 0, get_stack_base(gc), NULL); @@ -3234,8 +3554,11 @@ static void garbage_collect(NewGC *gc, int force_full) TIME_STEP("zeroed"); - if(gc->gc_full) do_heap_compact(gc); - + if(gc->gc_full) +#ifdef MZ_USE_PLACES + if (!MASTERGC) +#endif + do_heap_compact(gc); TIME_STEP("compacted"); /* do some cleanup structures that either change state based on the @@ -3250,7 +3573,7 @@ static void garbage_collect(NewGC *gc, int force_full) repair_roots(gc); repair_immobiles(gc); #ifdef MZ_USE_PLACES - if (!is_master_gc(gc)) + if (premaster_or_place_gc(gc)) #endif GC_fixup_variable_stack(GC_variable_stack, 0, get_stack_base(gc), NULL); TIME_STEP("reparied roots"); @@ -3258,15 +3581,28 @@ static void garbage_collect(NewGC *gc, int force_full) TIME_STEP("repaired"); clean_up_heap(gc); TIME_STEP("cleaned heap"); - reset_nursery(gc); +#ifdef MZ_USE_PLACES + if (premaster_or_place_gc(gc)) +#endif + reset_nursery(gc); TIME_STEP("reset nursurey"); #ifdef NEWGC_BTC_ACCOUNT if (gc->gc_full) BTC_do_accounting(gc); #endif TIME_STEP("accounted"); - if (gc->generations_available) + if (gc->generations_available) { +#ifdef MZ_USE_PLACES + if (postmaster_and_master_gc(gc)) { + unprotect_old_pages(gc); + } + else { + protect_old_pages(gc); + } +#else protect_old_pages(gc); +#endif +} TIME_STEP("protect"); if (gc->gc_full) vm_flush_freed_pages(gc->vm); @@ -3353,6 +3689,19 @@ static void garbage_collect(NewGC *gc, int force_full) if (next_gc_full) gc->full_needed_for_finalization = 1; + +#ifdef MZ_USE_PLACES + if (postmaster_and_place_gc(gc)) { + if (gc->gc_full) { + NewGCMasterInfo_set_have_collected(); + } + /* printf("UN RD MGCLOCK garbage_collect %i\n", GC_objhead_template.owner); */ + mzrt_rwlock_unlock(MASTERGCINFO->cangc); + if (gc->gc_full) { + Master_collect(); + } + } +#endif } #if MZ_GC_BACKTRACE @@ -3412,7 +3761,8 @@ void GC_free_all(void) next = work->next; if (work->mprotected) - vm_protect_pages(work->addr, (work->size_class > 1) ? round_to_apage_size(work->size) : APAGE_SIZE, 1); + vm_protect_pages(work->addr, real_page_size(work), 1); + GCVERBOSEPAGE("Cleaning up GC DYING", work); gen1_free_mpage(pagemap, work); } } diff --git a/src/mzscheme/gc2/newgc.h b/src/mzscheme/gc2/newgc.h index cc5962bde8..cfb3acca3c 100644 --- a/src/mzscheme/gc2/newgc.h +++ b/src/mzscheme/gc2/newgc.h @@ -88,6 +88,8 @@ typedef struct Page_Range { #ifdef MZ_USE_PLACES typedef struct NewGCMasterInfo { unsigned short next_GC_id; + unsigned char *have_collected; + void **signal_fds; mzrt_rwlock *cangc; } NewGCMasterInfo; #endif @@ -173,6 +175,7 @@ typedef struct NewGC { /* Distributed GC over places info */ #ifdef MZ_USE_PLACES objhead saved_GC_objhead_template; + int major_places_gc; /* :1; */ #endif struct mpage *thread_local_pages; diff --git a/src/mzscheme/gc2/sighand.c b/src/mzscheme/gc2/sighand.c index 02b69091ad..6512d3b61e 100644 --- a/src/mzscheme/gc2/sighand.c +++ b/src/mzscheme/gc2/sighand.c @@ -1,6 +1,6 @@ /* Provides: - initialize_signal_handler(); + initialize_signal_handler(GCTYPE *gc) remove_signal_handler(); Requires: generations_available - mutable int, Windows only @@ -41,6 +41,8 @@ static void launchgdb() { void fault_handler(int sn, struct siginfo *si, void *ctx) { void *p = si->si_addr; + int c = si->si_code; + int m = 0; if (si->si_code != SEGV_ACCERR) { /*SEGV_MAPERR*/ printf("SIGSEGV fault on %p\n", p); #if WAIT_FOR_GDB @@ -51,6 +53,12 @@ void fault_handler(int sn, struct siginfo *si, void *ctx) if (!designate_modified(p)) { if (si->si_code == SEGV_ACCERR) { +#ifdef MZ_USE_PLACES + if(pagemap_find_page(MASTERGC->page_maps, p)) { + m = 1; + printf("OWNED BY MASTER %p\n", p); + } +#endif printf("mprotect fault on %p\n", p); } else { @@ -139,7 +147,11 @@ void fault_handler(int sn, siginfo_t *si, void *ctx) static void initialize_signal_handler(GCTYPE *gc) { # ifdef NEED_OSX_MACH_HANDLER - macosx_init_exception_handler(); +# if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) + macosx_init_exception_handler(MASTERGC == 0); +# else + macosx_init_exception_handler(1); +# endif # endif # ifdef NEED_SIGACTION { diff --git a/src/mzscheme/gc2/vm_osx.c b/src/mzscheme/gc2/vm_osx.c index 6d01b12103..4cf8233177 100644 --- a/src/mzscheme/gc2/vm_osx.c +++ b/src/mzscheme/gc2/vm_osx.c @@ -35,6 +35,64 @@ static int designate_modified(void *p); int designate_modified(void *p); #endif +#if defined(MZ_USE_PLACES) && defined (MZ_PRECISE_GC) +typedef struct OSXThreadData { + struct OSXThreadData *next; + mach_port_t thread_port_id; + Thread_Local_Variables *tlvs; +} OSXThreadData; + +/* static const int OSX_THREAD_TABLE_SIZE = 256; */ +#define OSX_THREAD_TABLE_SIZE 256 +static OSXThreadData *osxthreads[OSX_THREAD_TABLE_SIZE]; +static pthread_mutex_t osxthreadsmutex = PTHREAD_MUTEX_INITIALIZER; + +static Thread_Local_Variables *get_mach_thread_tlvs(mach_port_t threadid) { + int index = threadid % OSX_THREAD_TABLE_SIZE; + OSXThreadData *thread; + Thread_Local_Variables *tlvs = NULL; + + pthread_mutex_lock(&osxthreadsmutex); + { + for (thread = osxthreads[index]; thread; thread = thread->next) + { + if (thread->thread_port_id == threadid) { + tlvs = thread->tlvs; + break; + } + } + } + pthread_mutex_unlock(&osxthreadsmutex); + + return tlvs; +} + +static void set_thread_locals_from_mach_thread_id(mach_port_t threadid) { + Thread_Local_Variables *tlvs = get_mach_thread_tlvs(threadid); +#ifdef USE_THREAD_LOCAL + pthread_setspecific(scheme_thread_local_key, tlvs); +#endif +} + +static void register_mach_thread() { + mach_port_t thread_self = mach_thread_self(); + int index = thread_self % OSX_THREAD_TABLE_SIZE; + OSXThreadData * thread = malloc(sizeof(OSXThreadData)); + + thread->thread_port_id = thread_self; + thread->tlvs = scheme_get_thread_local_variables(); + + /* PUSH thread record onto osxthreads datastructure */ + pthread_mutex_lock(&osxthreadsmutex); + { + thread->next = osxthreads[index]; + osxthreads[index] = thread; + } + pthread_mutex_unlock(&osxthreadsmutex); +} + +#endif + #if defined(__POWERPC__) # define ARCH_thread_state_t ppc_thread_state_t # define ARCH_THREAD_STATE PPC_THREAD_STATE @@ -227,6 +285,11 @@ kern_return_t GC_catch_exception_raise(mach_port_t port, &exc_state_count); p = (void *)exc_state.__faultvaddr; #endif + +#if defined(MZ_USE_PLACES) && defined (MZ_PRECISE_GC) + set_thread_locals_from_mach_thread_id(thread_port); +#endif + if (designate_modified(p)) return KERN_SUCCESS; else @@ -306,14 +369,22 @@ void GC_attach_current_thread_exceptions_to_handler() GCPRINT(GCOUTF, "Couldn't set exception ports: %s\n", mach_error_string(retval)); abort(); } +#if defined(MZ_USE_PLACES) && defined (MZ_PRECISE_GC) + register_mach_thread(); +#endif } /* this initializes the subsystem (sets the exception port, starts the exception handling thread, etc) */ -static void macosx_init_exception_handler() +static void macosx_init_exception_handler(int isMASTERGC) { kern_return_t retval; + if (!isMASTERGC) { + GC_attach_current_thread_exceptions_to_handler(); + return; + } + if(!task_self) task_self = mach_task_self(); /* allocate the port we're going to get exceptions on */ diff --git a/src/mzscheme/include/scheme.h b/src/mzscheme/include/scheme.h index 891b1c4caa..7589873457 100644 --- a/src/mzscheme/include/scheme.h +++ b/src/mzscheme/include/scheme.h @@ -318,6 +318,12 @@ typedef struct Scheme_Vector { Scheme_Object *els[1]; } Scheme_Vector; +typedef struct Scheme_Double_Vector { + Scheme_Object so; + long size; + double els[1]; +} Scheme_Double_Vector; + typedef struct Scheme_Print_Params Scheme_Print_Params; typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Print_Params *pp); @@ -435,6 +441,8 @@ typedef long (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj, void *cycle_data) #define SCHEME_MUTABLE_VECTORP(obj) (SCHEME_VECTORP(obj) && SCHEME_MUTABLEP(obj)) #define SCHEME_IMMUTABLE_VECTORP(obj) (SCHEME_VECTORP(obj) && SCHEME_IMMUTABLEP(obj)) +#define SCHEME_FLVECTORP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_flvector_type) + #define SCHEME_STRUCTP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_structure_type) || SAME_TYPE(SCHEME_TYPE(obj), scheme_proc_struct_type)) #define SCHEME_STRUCT_TYPEP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_struct_type_type) @@ -539,6 +547,9 @@ typedef long (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj, void *cycle_data) #define SCHEME_VEC_ELS(obj) (((Scheme_Vector *)(obj))->els) #define SCHEME_VEC_BASE(obj) SCHEME_VEC_ELS(obj) +#define SCHEME_FLVEC_SIZE(obj) (((Scheme_Double_Vector *)(obj))->size) +#define SCHEME_FLVEC_ELS(obj) (((Scheme_Double_Vector *)(obj))->els) + #define SCHEME_ENVBOX_VAL(obj) (*((Scheme_Object **)(obj))) #define SCHEME_WEAK_BOX_VAL(obj) SCHEME_BOX_VAL(obj) @@ -1745,6 +1756,7 @@ MZ_EXTERN Scheme_Object *scheme_set_exec_cmd(char *s); MZ_EXTERN Scheme_Object *scheme_set_run_cmd(char *s); MZ_EXTERN void scheme_set_collects_path(Scheme_Object *p); MZ_EXTERN void scheme_set_original_dir(Scheme_Object *d); +MZ_EXTERN void scheme_set_addon_dir(Scheme_Object *p); MZ_EXTERN void scheme_init_collection_paths(Scheme_Env *global_env, Scheme_Object *extra_dirs); MZ_EXTERN void scheme_init_collection_paths_post(Scheme_Env *global_env, Scheme_Object *extra_dirs, Scheme_Object *extra_post_dirs); diff --git a/src/mzscheme/src/cstartup.inc b/src/mzscheme/src/cstartup.inc index 51a29c08c7..a3bcfd6396 100644 --- a/src/mzscheme/src/cstartup.inc +++ b/src/mzscheme/src/cstartup.inc @@ -1,77 +1,77 @@ { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,51,46,50,50,0,0,0,1,0,0,3,0,12,0, -17,0,20,0,27,0,40,0,47,0,51,0,58,0,63,0,68,0,72,0,78, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,51,46,52,50,0,0,0,1,0,0,3,0,12,0, +19,0,23,0,28,0,41,0,44,0,49,0,56,0,63,0,67,0,72,0,78, 0,92,0,106,0,109,0,115,0,119,0,121,0,132,0,134,0,148,0,155,0, 177,0,179,0,193,0,4,1,33,1,44,1,55,1,65,1,101,1,134,1,167, 1,226,1,36,2,114,2,180,2,185,2,205,2,96,3,116,3,167,3,233,3, 118,4,4,5,56,5,79,5,158,5,0,0,105,7,0,0,29,11,11,68,104, -101,114,101,45,115,116,120,64,99,111,110,100,62,111,114,66,108,101,116,114,101, -99,72,112,97,114,97,109,101,116,101,114,105,122,101,66,117,110,108,101,115,115, -63,108,101,116,66,100,101,102,105,110,101,64,119,104,101,110,64,108,101,116,42, -63,97,110,100,65,113,117,111,116,101,29,94,2,13,68,35,37,107,101,114,110, +101,114,101,45,115,116,120,66,100,101,102,105,110,101,63,97,110,100,64,108,101, +116,42,72,112,97,114,97,109,101,116,101,114,105,122,101,62,111,114,64,99,111, +110,100,66,108,101,116,114,101,99,66,117,110,108,101,115,115,63,108,101,116,64, +119,104,101,110,65,113,117,111,116,101,29,94,2,13,68,35,37,107,101,114,110, 101,108,11,29,94,2,13,68,35,37,112,97,114,97,109,122,11,62,105,102,65, 98,101,103,105,110,63,115,116,120,61,115,70,108,101,116,45,118,97,108,117,101, 115,61,120,73,108,101,116,114,101,99,45,118,97,108,117,101,115,66,108,97,109, 98,100,97,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110, 45,107,101,121,61,118,73,100,101,102,105,110,101,45,118,97,108,117,101,115,97, -35,11,8,240,168,70,0,0,95,159,2,15,35,35,159,2,14,35,35,159,2, -14,35,35,16,20,2,3,2,1,2,5,2,1,2,6,2,1,2,7,2,1, -2,8,2,1,2,9,2,1,2,10,2,1,2,4,2,1,2,11,2,1,2, -12,2,1,97,36,11,8,240,168,70,0,0,93,159,2,14,35,36,16,2,2, -2,161,2,1,36,2,2,2,1,2,2,96,11,11,8,240,168,70,0,0,16, -0,96,37,11,8,240,168,70,0,0,16,0,13,16,4,35,29,11,11,2,1, +35,11,8,240,35,79,0,0,95,159,2,15,35,35,159,2,14,35,35,159,2, +14,35,35,16,20,2,3,2,1,2,7,2,1,2,4,2,1,2,5,2,1, +2,6,2,1,2,9,2,1,2,8,2,1,2,10,2,1,2,11,2,1,2, +12,2,1,97,36,11,8,240,35,79,0,0,93,159,2,14,35,36,16,2,2, +2,161,2,1,36,2,2,2,1,2,2,96,11,11,8,240,35,79,0,0,16, +0,96,37,11,8,240,35,79,0,0,16,0,13,16,4,35,29,11,11,2,1, 11,18,16,2,99,64,104,101,114,101,8,31,8,30,8,29,8,28,8,27,93, -8,224,175,70,0,0,95,9,8,224,175,70,0,0,2,1,27,248,22,137,4, -195,249,22,130,4,80,158,38,35,251,22,77,2,16,248,22,92,199,12,249,22, -67,2,17,248,22,94,201,27,248,22,137,4,195,249,22,130,4,80,158,38,35, +8,224,42,79,0,0,95,9,8,224,42,79,0,0,2,1,27,248,22,143,4, +195,249,22,136,4,80,158,38,35,251,22,77,2,16,248,22,92,199,12,249,22, +67,2,17,248,22,94,201,27,248,22,143,4,195,249,22,136,4,80,158,38,35, 251,22,77,2,16,248,22,92,199,249,22,67,2,17,248,22,94,201,12,27,248, -22,69,248,22,137,4,196,28,248,22,75,193,20,15,159,36,35,36,28,248,22, -75,248,22,69,194,248,22,68,193,249,22,130,4,80,158,38,35,251,22,77,2, -16,248,22,68,199,249,22,67,2,12,248,22,69,201,11,18,16,2,101,10,8, +22,69,248,22,143,4,196,28,248,22,75,193,20,15,159,36,35,36,28,248,22, +75,248,22,69,194,248,22,68,193,249,22,136,4,80,158,38,35,251,22,77,2, +16,248,22,68,199,249,22,67,2,4,248,22,69,201,11,18,16,2,101,10,8, 31,8,30,8,29,8,28,8,27,16,4,11,11,2,18,3,1,8,101,110,118, -49,49,51,56,56,16,4,11,11,2,19,3,1,8,101,110,118,49,49,51,56, -57,93,8,224,176,70,0,0,95,9,8,224,176,70,0,0,2,1,27,248,22, -69,248,22,137,4,196,28,248,22,75,193,20,15,159,36,35,36,28,248,22,75, -248,22,69,194,248,22,68,193,249,22,130,4,80,158,38,35,250,22,77,2,20, +49,50,57,54,48,16,4,11,11,2,19,3,1,8,101,110,118,49,50,57,54, +49,93,8,224,43,79,0,0,95,9,8,224,43,79,0,0,2,1,27,248,22, +69,248,22,143,4,196,28,248,22,75,193,20,15,159,36,35,36,28,248,22,75, +248,22,69,194,248,22,68,193,249,22,136,4,80,158,38,35,250,22,77,2,20, 248,22,77,249,22,77,248,22,77,2,21,248,22,68,201,251,22,77,2,16,2, -21,2,21,249,22,67,2,4,248,22,69,204,18,16,2,101,11,8,31,8,30, -8,29,8,28,8,27,16,4,11,11,2,18,3,1,8,101,110,118,49,49,51, -57,49,16,4,11,11,2,19,3,1,8,101,110,118,49,49,51,57,50,93,8, -224,177,70,0,0,95,9,8,224,177,70,0,0,2,1,248,22,137,4,193,27, -248,22,137,4,194,249,22,67,248,22,77,248,22,68,196,248,22,69,195,27,248, -22,69,248,22,137,4,23,197,1,249,22,130,4,80,158,38,35,28,248,22,53, -248,22,131,4,248,22,68,23,198,2,27,249,22,2,32,0,89,162,8,44,36, -42,9,222,33,39,248,22,137,4,248,22,92,23,200,2,250,22,77,2,22,248, +21,2,21,249,22,67,2,7,248,22,69,204,18,16,2,101,11,8,31,8,30, +8,29,8,28,8,27,16,4,11,11,2,18,3,1,8,101,110,118,49,50,57, +54,51,16,4,11,11,2,19,3,1,8,101,110,118,49,50,57,54,52,93,8, +224,44,79,0,0,95,9,8,224,44,79,0,0,2,1,248,22,143,4,193,27, +248,22,143,4,194,249,22,67,248,22,77,248,22,68,196,248,22,69,195,27,248, +22,69,248,22,143,4,23,197,1,249,22,136,4,80,158,38,35,28,248,22,53, +248,22,137,4,248,22,68,23,198,2,27,249,22,2,32,0,89,162,8,44,36, +42,9,222,33,39,248,22,143,4,248,22,92,23,200,2,250,22,77,2,22,248, 22,77,249,22,77,248,22,77,248,22,68,23,204,2,250,22,78,2,23,249,22, 2,22,68,23,204,2,248,22,94,23,206,2,249,22,67,248,22,68,23,202,1, 249,22,2,22,92,23,200,1,250,22,78,2,20,249,22,2,32,0,89,162,8, -44,36,46,9,222,33,40,248,22,137,4,248,22,68,201,248,22,69,198,27,248, -22,137,4,194,249,22,67,248,22,77,248,22,68,196,248,22,69,195,27,248,22, -69,248,22,137,4,23,197,1,249,22,130,4,80,158,38,35,250,22,78,2,22, -249,22,2,32,0,89,162,8,44,36,46,9,222,33,42,248,22,137,4,248,22, -68,201,248,22,69,198,27,248,22,69,248,22,137,4,196,27,248,22,137,4,248, -22,68,195,249,22,130,4,80,158,39,35,28,248,22,75,195,250,22,78,2,20, -9,248,22,69,199,250,22,77,2,8,248,22,77,248,22,68,199,250,22,78,2, -11,248,22,69,201,248,22,69,202,27,248,22,69,248,22,137,4,23,197,1,27, -249,22,1,22,81,249,22,2,22,137,4,248,22,137,4,248,22,68,199,249,22, -130,4,80,158,39,35,251,22,77,1,22,119,105,116,104,45,99,111,110,116,105, +44,36,46,9,222,33,40,248,22,143,4,248,22,68,201,248,22,69,198,27,248, +22,143,4,194,249,22,67,248,22,77,248,22,68,196,248,22,69,195,27,248,22, +69,248,22,143,4,23,197,1,249,22,136,4,80,158,38,35,250,22,78,2,22, +249,22,2,32,0,89,162,8,44,36,46,9,222,33,42,248,22,143,4,248,22, +68,201,248,22,69,198,27,248,22,69,248,22,143,4,196,27,248,22,143,4,248, +22,68,195,249,22,136,4,80,158,39,35,28,248,22,75,195,250,22,78,2,20, +9,248,22,69,199,250,22,77,2,11,248,22,77,248,22,68,199,250,22,78,2, +5,248,22,69,201,248,22,69,202,27,248,22,69,248,22,143,4,23,197,1,27, +249,22,1,22,81,249,22,2,22,143,4,248,22,143,4,248,22,68,199,249,22, +136,4,80,158,39,35,251,22,77,1,22,119,105,116,104,45,99,111,110,116,105, 110,117,97,116,105,111,110,45,109,97,114,107,2,24,250,22,78,1,23,101,120, 116,101,110,100,45,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110, 21,95,1,27,99,111,110,116,105,110,117,97,116,105,111,110,45,109,97,114,107, 45,115,101,116,45,102,105,114,115,116,11,2,24,201,250,22,78,2,20,9,248, -22,69,203,27,248,22,69,248,22,137,4,196,28,248,22,75,193,20,15,159,36, -35,36,249,22,130,4,80,158,38,35,27,248,22,137,4,248,22,68,197,28,249, -22,167,8,62,61,62,248,22,131,4,248,22,92,196,250,22,77,2,20,248,22, -77,249,22,77,21,93,2,25,248,22,68,199,250,22,78,2,3,249,22,77,2, +22,69,203,27,248,22,69,248,22,143,4,196,28,248,22,75,193,20,15,159,36, +35,36,249,22,136,4,80,158,38,35,27,248,22,143,4,248,22,68,197,28,249, +22,173,8,62,61,62,248,22,137,4,248,22,92,196,250,22,77,2,20,248,22, +77,249,22,77,21,93,2,25,248,22,68,199,250,22,78,2,8,249,22,77,2, 25,249,22,77,248,22,101,203,2,25,248,22,69,202,251,22,77,2,16,28,249, -22,167,8,248,22,131,4,248,22,68,200,64,101,108,115,101,10,248,22,68,197, -250,22,78,2,20,9,248,22,69,200,249,22,67,2,3,248,22,69,202,100,8, +22,173,8,248,22,137,4,248,22,68,200,64,101,108,115,101,10,248,22,68,197, +250,22,78,2,20,9,248,22,69,200,249,22,67,2,8,248,22,69,202,100,8, 31,8,30,8,29,8,28,8,27,16,4,11,11,2,18,3,1,8,101,110,118, -49,49,52,49,52,16,4,11,11,2,19,3,1,8,101,110,118,49,49,52,49, -53,93,8,224,178,70,0,0,18,16,2,158,94,10,64,118,111,105,100,8,47, -95,9,8,224,178,70,0,0,2,1,27,248,22,69,248,22,137,4,196,249,22, -130,4,80,158,38,35,28,248,22,53,248,22,131,4,248,22,68,197,250,22,77, -2,26,248,22,77,248,22,68,199,248,22,92,198,27,248,22,131,4,248,22,68, +49,50,57,56,54,16,4,11,11,2,19,3,1,8,101,110,118,49,50,57,56, +55,93,8,224,45,79,0,0,18,16,2,158,94,10,64,118,111,105,100,8,47, +95,9,8,224,45,79,0,0,2,1,27,248,22,69,248,22,143,4,196,249,22, +136,4,80,158,38,35,28,248,22,53,248,22,137,4,248,22,68,197,250,22,77, +2,26,248,22,77,248,22,68,199,248,22,92,198,27,248,22,137,4,248,22,68, 197,250,22,77,2,26,248,22,77,248,22,68,197,250,22,78,2,23,248,22,69, 199,248,22,69,202,159,35,20,102,159,35,16,1,11,16,0,83,158,41,20,100, 144,69,35,37,109,105,110,45,115,116,120,2,1,11,11,11,10,35,80,158,35, @@ -81,25 +81,25 @@ 2,3,2,4,2,5,2,6,2,7,2,8,2,9,2,10,2,11,2,12,35, 45,36,11,11,11,16,0,16,0,16,0,35,35,11,11,11,11,16,0,16,0, 16,0,35,35,16,11,16,5,2,2,20,15,159,35,35,35,35,20,102,159,35, -16,0,16,1,33,32,10,16,5,2,7,89,162,8,44,36,52,9,223,0,33, -33,35,20,102,159,35,16,1,2,2,16,0,11,16,5,2,10,89,162,8,44, +16,0,16,1,33,32,10,16,5,2,10,89,162,8,44,36,52,9,223,0,33, +33,35,20,102,159,35,16,1,2,2,16,0,11,16,5,2,12,89,162,8,44, 36,52,9,223,0,33,34,35,20,102,159,35,16,1,2,2,16,0,11,16,5, -2,12,89,162,8,44,36,52,9,223,0,33,35,35,20,102,159,35,16,1,2, -2,16,1,33,36,11,16,5,2,4,89,162,8,44,36,55,9,223,0,33,37, -35,20,102,159,35,16,1,2,2,16,1,33,38,11,16,5,2,8,89,162,8, +2,4,89,162,8,44,36,52,9,223,0,33,35,35,20,102,159,35,16,1,2, +2,16,1,33,36,11,16,5,2,7,89,162,8,44,36,55,9,223,0,33,37, +35,20,102,159,35,16,1,2,2,16,1,33,38,11,16,5,2,11,89,162,8, 44,36,57,9,223,0,33,41,35,20,102,159,35,16,1,2,2,16,0,11,16, -5,2,5,89,162,8,44,36,52,9,223,0,33,43,35,20,102,159,35,16,1, -2,2,16,0,11,16,5,2,11,89,162,8,44,36,53,9,223,0,33,44,35, +5,2,9,89,162,8,44,36,52,9,223,0,33,43,35,20,102,159,35,16,1, +2,2,16,0,11,16,5,2,5,89,162,8,44,36,53,9,223,0,33,44,35, 20,102,159,35,16,1,2,2,16,0,11,16,5,2,6,89,162,8,44,36,54, -9,223,0,33,45,35,20,102,159,35,16,1,2,2,16,0,11,16,5,2,3, +9,223,0,33,45,35,20,102,159,35,16,1,2,2,16,0,11,16,5,2,8, 89,162,8,44,36,57,9,223,0,33,46,35,20,102,159,35,16,1,2,2,16, -1,33,48,11,16,5,2,9,89,162,8,44,36,53,9,223,0,33,49,35,20, +1,33,48,11,16,5,2,3,89,162,8,44,36,53,9,223,0,33,49,35,20, 102,159,35,16,1,2,2,16,0,11,16,0,94,2,14,2,15,93,2,14,9, 9,35,0}; EVAL_ONE_SIZED_STR((char *)expr, 2018); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,51,46,50,59,0,0,0,1,0,0,13,0,18,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,51,46,52,59,0,0,0,1,0,0,13,0,18,0, 35,0,50,0,68,0,84,0,94,0,112,0,132,0,148,0,166,0,197,0,226, 0,248,0,6,1,12,1,26,1,31,1,41,1,49,1,77,1,109,1,154,1, 199,1,223,1,6,2,8,2,65,2,155,3,196,3,31,5,135,5,239,5,100, @@ -131,176 +131,176 @@ 116,101,32,115,116,114,105,110,103,6,36,36,99,97,110,110,111,116,32,97,100, 100,32,97,32,115,117,102,102,105,120,32,116,111,32,97,32,114,111,111,116,32, 112,97,116,104,58,32,5,0,27,20,14,159,80,158,36,50,250,80,158,39,51, -249,22,27,11,80,158,41,50,22,189,12,10,248,22,160,5,23,196,2,28,248, -22,157,6,23,194,2,12,87,94,248,22,171,8,23,194,1,248,80,159,37,53, +249,22,27,11,80,158,41,50,22,131,13,10,248,22,166,5,23,196,2,28,248, +22,163,6,23,194,2,12,87,94,248,22,177,8,23,194,1,248,80,159,37,53, 36,195,28,248,22,75,23,195,2,9,27,248,22,68,23,196,2,27,28,248,22, -171,13,23,195,2,23,194,1,28,248,22,170,13,23,195,2,249,22,172,13,23, -196,1,250,80,158,42,48,248,22,187,13,2,19,11,10,250,80,158,40,48,248, -22,187,13,2,19,23,197,1,10,28,23,193,2,249,22,67,248,22,174,13,249, -22,172,13,23,198,1,247,22,188,13,27,248,22,69,23,200,1,28,248,22,75, -23,194,2,9,27,248,22,68,23,195,2,27,28,248,22,171,13,23,195,2,23, -194,1,28,248,22,170,13,23,195,2,249,22,172,13,23,196,1,250,80,158,47, -48,248,22,187,13,2,19,11,10,250,80,158,45,48,248,22,187,13,2,19,23, -197,1,10,28,23,193,2,249,22,67,248,22,174,13,249,22,172,13,23,198,1, -247,22,188,13,248,80,159,45,52,36,248,22,69,23,199,1,87,94,23,193,1, +177,13,23,195,2,23,194,1,28,248,22,176,13,23,195,2,249,22,178,13,23, +196,1,250,80,158,42,48,248,22,129,14,2,19,11,10,250,80,158,40,48,248, +22,129,14,2,19,23,197,1,10,28,23,193,2,249,22,67,248,22,180,13,249, +22,178,13,23,198,1,247,22,130,14,27,248,22,69,23,200,1,28,248,22,75, +23,194,2,9,27,248,22,68,23,195,2,27,28,248,22,177,13,23,195,2,23, +194,1,28,248,22,176,13,23,195,2,249,22,178,13,23,196,1,250,80,158,47, +48,248,22,129,14,2,19,11,10,250,80,158,45,48,248,22,129,14,2,19,23, +197,1,10,28,23,193,2,249,22,67,248,22,180,13,249,22,178,13,23,198,1, +247,22,130,14,248,80,159,45,52,36,248,22,69,23,199,1,87,94,23,193,1, 248,80,159,43,52,36,248,22,69,23,197,1,87,94,23,193,1,27,248,22,69, 23,198,1,28,248,22,75,23,194,2,9,27,248,22,68,23,195,2,27,28,248, -22,171,13,23,195,2,23,194,1,28,248,22,170,13,23,195,2,249,22,172,13, -23,196,1,250,80,158,45,48,248,22,187,13,2,19,11,10,250,80,158,43,48, -248,22,187,13,2,19,23,197,1,10,28,23,193,2,249,22,67,248,22,174,13, -249,22,172,13,23,198,1,247,22,188,13,248,80,159,43,52,36,248,22,69,23, -199,1,248,80,159,41,52,36,248,22,69,196,27,248,22,147,13,23,195,2,28, -23,193,2,192,87,94,23,193,1,28,248,22,162,6,23,195,2,27,248,22,169, -13,195,28,192,192,248,22,170,13,195,11,87,94,28,28,248,22,148,13,23,195, -2,10,27,248,22,147,13,23,196,2,28,23,193,2,192,87,94,23,193,1,28, -248,22,162,6,23,196,2,27,248,22,169,13,23,197,2,28,23,193,2,192,87, -94,23,193,1,248,22,170,13,23,197,2,11,12,250,22,135,9,76,110,111,114, +22,177,13,23,195,2,23,194,1,28,248,22,176,13,23,195,2,249,22,178,13, +23,196,1,250,80,158,45,48,248,22,129,14,2,19,11,10,250,80,158,43,48, +248,22,129,14,2,19,23,197,1,10,28,23,193,2,249,22,67,248,22,180,13, +249,22,178,13,23,198,1,247,22,130,14,248,80,159,43,52,36,248,22,69,23, +199,1,248,80,159,41,52,36,248,22,69,196,27,248,22,153,13,23,195,2,28, +23,193,2,192,87,94,23,193,1,28,248,22,168,6,23,195,2,27,248,22,175, +13,195,28,192,192,248,22,176,13,195,11,87,94,28,28,248,22,154,13,23,195, +2,10,27,248,22,153,13,23,196,2,28,23,193,2,192,87,94,23,193,1,28, +248,22,168,6,23,196,2,27,248,22,175,13,23,197,2,28,23,193,2,192,87, +94,23,193,1,248,22,176,13,23,197,2,11,12,250,22,141,9,76,110,111,114, 109,97,108,45,112,97,116,104,45,99,97,115,101,6,42,42,112,97,116,104,32, 40,102,111,114,32,97,110,121,32,115,121,115,116,101,109,41,32,111,114,32,118, 97,108,105,100,45,112,97,116,104,32,115,116,114,105,110,103,23,197,2,28,28, -248,22,148,13,23,195,2,249,22,167,8,248,22,149,13,23,197,2,2,20,249, -22,167,8,247,22,181,7,2,20,27,28,248,22,162,6,23,196,2,23,195,2, -248,22,171,7,248,22,152,13,23,197,2,28,249,22,136,14,0,21,35,114,120, +248,22,154,13,23,195,2,249,22,173,8,248,22,155,13,23,197,2,2,20,249, +22,173,8,247,22,187,7,2,20,27,28,248,22,168,6,23,196,2,23,195,2, +248,22,177,7,248,22,158,13,23,197,2,28,249,22,142,14,0,21,35,114,120, 34,94,91,92,92,93,91,92,92,93,91,63,93,91,92,92,93,34,23,195,2, -28,248,22,162,6,195,248,22,155,13,195,194,27,248,22,137,7,23,195,1,249, -22,156,13,248,22,174,7,250,22,142,14,0,6,35,114,120,34,47,34,28,249, -22,136,14,0,22,35,114,120,34,91,47,92,92,93,91,46,32,93,43,91,47, -92,92,93,42,36,34,23,201,2,23,199,1,250,22,142,14,0,19,35,114,120, +28,248,22,168,6,195,248,22,161,13,195,194,27,248,22,143,7,23,195,1,249, +22,162,13,248,22,180,7,250,22,148,14,0,6,35,114,120,34,47,34,28,249, +22,142,14,0,22,35,114,120,34,91,47,92,92,93,91,46,32,93,43,91,47, +92,92,93,42,36,34,23,201,2,23,199,1,250,22,148,14,0,19,35,114,120, 34,91,32,46,93,43,40,91,47,92,92,93,42,41,36,34,23,202,1,6,2, -2,92,49,80,159,43,36,37,2,20,28,248,22,162,6,194,248,22,155,13,194, -193,87,94,28,27,248,22,147,13,23,196,2,28,23,193,2,192,87,94,23,193, -1,28,248,22,162,6,23,196,2,27,248,22,169,13,23,197,2,28,23,193,2, -192,87,94,23,193,1,248,22,170,13,23,197,2,11,12,250,22,135,9,23,196, -2,2,21,23,197,2,28,248,22,169,13,23,195,2,12,248,22,165,11,249,22, -174,10,248,22,191,6,250,22,146,7,2,22,23,200,1,23,201,1,247,22,23, -87,94,28,27,248,22,147,13,23,196,2,28,23,193,2,192,87,94,23,193,1, -28,248,22,162,6,23,196,2,27,248,22,169,13,23,197,2,28,23,193,2,192, -87,94,23,193,1,248,22,170,13,23,197,2,11,12,250,22,135,9,23,196,2, -2,21,23,197,2,28,248,22,169,13,23,195,2,12,248,22,165,11,249,22,174, -10,248,22,191,6,250,22,146,7,2,22,23,200,1,23,201,1,247,22,23,87, -94,87,94,28,27,248,22,147,13,23,196,2,28,23,193,2,192,87,94,23,193, -1,28,248,22,162,6,23,196,2,27,248,22,169,13,23,197,2,28,23,193,2, -192,87,94,23,193,1,248,22,170,13,23,197,2,11,12,250,22,135,9,195,2, -21,23,197,2,28,248,22,169,13,23,195,2,12,248,22,165,11,249,22,174,10, -248,22,191,6,250,22,146,7,2,22,199,23,201,1,247,22,23,249,22,3,89, -162,8,44,36,49,9,223,2,33,33,196,248,22,165,11,249,22,140,11,23,196, +2,92,49,80,159,43,36,37,2,20,28,248,22,168,6,194,248,22,161,13,194, +193,87,94,28,27,248,22,153,13,23,196,2,28,23,193,2,192,87,94,23,193, +1,28,248,22,168,6,23,196,2,27,248,22,175,13,23,197,2,28,23,193,2, +192,87,94,23,193,1,248,22,176,13,23,197,2,11,12,250,22,141,9,23,196, +2,2,21,23,197,2,28,248,22,175,13,23,195,2,12,248,22,171,11,249,22, +180,10,248,22,133,7,250,22,152,7,2,22,23,200,1,23,201,1,247,22,23, +87,94,28,27,248,22,153,13,23,196,2,28,23,193,2,192,87,94,23,193,1, +28,248,22,168,6,23,196,2,27,248,22,175,13,23,197,2,28,23,193,2,192, +87,94,23,193,1,248,22,176,13,23,197,2,11,12,250,22,141,9,23,196,2, +2,21,23,197,2,28,248,22,175,13,23,195,2,12,248,22,171,11,249,22,180, +10,248,22,133,7,250,22,152,7,2,22,23,200,1,23,201,1,247,22,23,87, +94,87,94,28,27,248,22,153,13,23,196,2,28,23,193,2,192,87,94,23,193, +1,28,248,22,168,6,23,196,2,27,248,22,175,13,23,197,2,28,23,193,2, +192,87,94,23,193,1,248,22,176,13,23,197,2,11,12,250,22,141,9,195,2, +21,23,197,2,28,248,22,175,13,23,195,2,12,248,22,171,11,249,22,180,10, +248,22,133,7,250,22,152,7,2,22,199,23,201,1,247,22,23,249,22,3,89, +162,8,44,36,49,9,223,2,33,33,196,248,22,171,11,249,22,146,11,23,196, 1,247,22,23,87,94,250,80,159,38,39,36,2,6,196,197,251,80,159,39,41, 36,2,6,32,0,89,162,8,44,36,44,9,222,33,35,197,198,32,37,89,162, 43,41,58,65,99,108,111,111,112,222,33,38,28,248,22,75,23,199,2,87,94, -23,198,1,248,23,196,1,251,22,146,7,2,23,23,199,1,28,248,22,75,23, -203,2,87,94,23,202,1,23,201,1,250,22,1,22,165,13,23,204,1,23,205, -1,23,198,1,27,249,22,165,13,248,22,68,23,202,2,23,199,2,28,248,22, -160,13,23,194,2,27,250,22,1,22,165,13,23,197,1,23,202,2,28,248,22, -160,13,23,194,2,192,87,94,23,193,1,27,248,22,69,23,202,1,28,248,22, -75,23,194,2,87,94,23,193,1,248,23,199,1,251,22,146,7,2,23,23,202, -1,28,248,22,75,23,206,2,87,94,23,205,1,23,204,1,250,22,1,22,165, -13,23,207,1,23,208,1,23,201,1,27,249,22,165,13,248,22,68,23,197,2, -23,202,2,28,248,22,160,13,23,194,2,27,250,22,1,22,165,13,23,197,1, -204,28,248,22,160,13,193,192,253,2,37,203,204,205,206,23,15,248,22,69,201, +23,198,1,248,23,196,1,251,22,152,7,2,23,23,199,1,28,248,22,75,23, +203,2,87,94,23,202,1,23,201,1,250,22,1,22,171,13,23,204,1,23,205, +1,23,198,1,27,249,22,171,13,248,22,68,23,202,2,23,199,2,28,248,22, +166,13,23,194,2,27,250,22,1,22,171,13,23,197,1,23,202,2,28,248,22, +166,13,23,194,2,192,87,94,23,193,1,27,248,22,69,23,202,1,28,248,22, +75,23,194,2,87,94,23,193,1,248,23,199,1,251,22,152,7,2,23,23,202, +1,28,248,22,75,23,206,2,87,94,23,205,1,23,204,1,250,22,1,22,171, +13,23,207,1,23,208,1,23,201,1,27,249,22,171,13,248,22,68,23,197,2, +23,202,2,28,248,22,166,13,23,194,2,27,250,22,1,22,171,13,23,197,1, +204,28,248,22,166,13,193,192,253,2,37,203,204,205,206,23,15,248,22,69,201, 253,2,37,202,203,204,205,206,248,22,69,200,87,94,23,193,1,27,248,22,69, 23,201,1,28,248,22,75,23,194,2,87,94,23,193,1,248,23,198,1,251,22, -146,7,2,23,23,201,1,28,248,22,75,23,205,2,87,94,23,204,1,23,203, -1,250,22,1,22,165,13,23,206,1,23,207,1,23,200,1,27,249,22,165,13, -248,22,68,23,197,2,23,201,2,28,248,22,160,13,23,194,2,27,250,22,1, -22,165,13,23,197,1,203,28,248,22,160,13,193,192,253,2,37,202,203,204,205, -206,248,22,69,201,253,2,37,201,202,203,204,205,248,22,69,200,27,247,22,189, -13,253,2,37,198,199,200,201,202,198,87,95,28,28,248,22,148,13,23,194,2, -10,27,248,22,147,13,23,195,2,28,23,193,2,192,87,94,23,193,1,28,248, -22,162,6,23,195,2,27,248,22,169,13,23,196,2,28,23,193,2,192,87,94, -23,193,1,248,22,170,13,23,196,2,11,12,252,22,135,9,23,200,2,2,24, -35,23,198,2,23,199,2,28,28,248,22,162,6,23,195,2,10,248,22,150,7, -23,195,2,87,94,23,194,1,12,252,22,135,9,23,200,2,2,25,36,23,198, -2,23,199,1,91,159,38,11,90,161,38,35,11,248,22,168,13,23,197,2,87, -94,23,195,1,87,94,28,192,12,250,22,136,9,23,201,1,2,26,23,199,1, -249,22,7,194,195,91,159,37,11,90,161,37,35,11,87,95,28,28,248,22,148, -13,23,196,2,10,27,248,22,147,13,23,197,2,28,23,193,2,192,87,94,23, -193,1,28,248,22,162,6,23,197,2,27,248,22,169,13,23,198,2,28,23,193, -2,192,87,94,23,193,1,248,22,170,13,23,198,2,11,12,252,22,135,9,2, -9,2,24,35,23,200,2,23,201,2,28,28,248,22,162,6,23,197,2,10,248, -22,150,7,23,197,2,12,252,22,135,9,2,9,2,25,36,23,200,2,23,201, -2,91,159,38,11,90,161,38,35,11,248,22,168,13,23,199,2,87,94,23,195, -1,87,94,28,192,12,250,22,136,9,2,9,2,26,23,201,2,249,22,7,194, -195,27,249,22,157,13,250,22,141,14,0,20,35,114,120,35,34,40,63,58,91, -46,93,91,94,46,93,42,124,41,36,34,248,22,153,13,23,201,1,28,248,22, -162,6,23,203,2,249,22,174,7,23,204,1,8,63,23,202,1,28,248,22,148, -13,23,199,2,248,22,149,13,23,199,1,87,94,23,198,1,247,22,150,13,28, -248,22,147,13,194,249,22,165,13,195,194,192,91,159,37,11,90,161,37,35,11, -87,95,28,28,248,22,148,13,23,196,2,10,27,248,22,147,13,23,197,2,28, -23,193,2,192,87,94,23,193,1,28,248,22,162,6,23,197,2,27,248,22,169, -13,23,198,2,28,23,193,2,192,87,94,23,193,1,248,22,170,13,23,198,2, -11,12,252,22,135,9,2,10,2,24,35,23,200,2,23,201,2,28,28,248,22, -162,6,23,197,2,10,248,22,150,7,23,197,2,12,252,22,135,9,2,10,2, -25,36,23,200,2,23,201,2,91,159,38,11,90,161,38,35,11,248,22,168,13, -23,199,2,87,94,23,195,1,87,94,28,192,12,250,22,136,9,2,10,2,26, -23,201,2,249,22,7,194,195,27,249,22,157,13,249,22,160,7,250,22,142,14, -0,9,35,114,120,35,34,91,46,93,34,248,22,153,13,23,203,1,6,1,1, -95,28,248,22,162,6,23,202,2,249,22,174,7,23,203,1,8,63,23,201,1, -28,248,22,148,13,23,199,2,248,22,149,13,23,199,1,87,94,23,198,1,247, -22,150,13,28,248,22,147,13,194,249,22,165,13,195,194,192,249,247,22,129,5, +152,7,2,23,23,201,1,28,248,22,75,23,205,2,87,94,23,204,1,23,203, +1,250,22,1,22,171,13,23,206,1,23,207,1,23,200,1,27,249,22,171,13, +248,22,68,23,197,2,23,201,2,28,248,22,166,13,23,194,2,27,250,22,1, +22,171,13,23,197,1,203,28,248,22,166,13,193,192,253,2,37,202,203,204,205, +206,248,22,69,201,253,2,37,201,202,203,204,205,248,22,69,200,27,247,22,131, +14,253,2,37,198,199,200,201,202,198,87,95,28,28,248,22,154,13,23,194,2, +10,27,248,22,153,13,23,195,2,28,23,193,2,192,87,94,23,193,1,28,248, +22,168,6,23,195,2,27,248,22,175,13,23,196,2,28,23,193,2,192,87,94, +23,193,1,248,22,176,13,23,196,2,11,12,252,22,141,9,23,200,2,2,24, +35,23,198,2,23,199,2,28,28,248,22,168,6,23,195,2,10,248,22,156,7, +23,195,2,87,94,23,194,1,12,252,22,141,9,23,200,2,2,25,36,23,198, +2,23,199,1,91,159,38,11,90,161,38,35,11,248,22,174,13,23,197,2,87, +94,23,195,1,87,94,28,192,12,250,22,142,9,23,201,1,2,26,23,199,1, +249,22,7,194,195,91,159,37,11,90,161,37,35,11,87,95,28,28,248,22,154, +13,23,196,2,10,27,248,22,153,13,23,197,2,28,23,193,2,192,87,94,23, +193,1,28,248,22,168,6,23,197,2,27,248,22,175,13,23,198,2,28,23,193, +2,192,87,94,23,193,1,248,22,176,13,23,198,2,11,12,252,22,141,9,2, +9,2,24,35,23,200,2,23,201,2,28,28,248,22,168,6,23,197,2,10,248, +22,156,7,23,197,2,12,252,22,141,9,2,9,2,25,36,23,200,2,23,201, +2,91,159,38,11,90,161,38,35,11,248,22,174,13,23,199,2,87,94,23,195, +1,87,94,28,192,12,250,22,142,9,2,9,2,26,23,201,2,249,22,7,194, +195,27,249,22,163,13,250,22,147,14,0,20,35,114,120,35,34,40,63,58,91, +46,93,91,94,46,93,42,124,41,36,34,248,22,159,13,23,201,1,28,248,22, +168,6,23,203,2,249,22,180,7,23,204,1,8,63,23,202,1,28,248,22,154, +13,23,199,2,248,22,155,13,23,199,1,87,94,23,198,1,247,22,156,13,28, +248,22,153,13,194,249,22,171,13,195,194,192,91,159,37,11,90,161,37,35,11, +87,95,28,28,248,22,154,13,23,196,2,10,27,248,22,153,13,23,197,2,28, +23,193,2,192,87,94,23,193,1,28,248,22,168,6,23,197,2,27,248,22,175, +13,23,198,2,28,23,193,2,192,87,94,23,193,1,248,22,176,13,23,198,2, +11,12,252,22,141,9,2,10,2,24,35,23,200,2,23,201,2,28,28,248,22, +168,6,23,197,2,10,248,22,156,7,23,197,2,12,252,22,141,9,2,10,2, +25,36,23,200,2,23,201,2,91,159,38,11,90,161,38,35,11,248,22,174,13, +23,199,2,87,94,23,195,1,87,94,28,192,12,250,22,142,9,2,10,2,26, +23,201,2,249,22,7,194,195,27,249,22,163,13,249,22,166,7,250,22,148,14, +0,9,35,114,120,35,34,91,46,93,34,248,22,159,13,23,203,1,6,1,1, +95,28,248,22,168,6,23,202,2,249,22,180,7,23,203,1,8,63,23,201,1, +28,248,22,154,13,23,199,2,248,22,155,13,23,199,1,87,94,23,198,1,247, +22,156,13,28,248,22,153,13,194,249,22,171,13,195,194,192,249,247,22,135,5, 194,11,249,80,159,37,46,36,9,9,249,80,159,37,46,36,195,9,27,247,22, -191,13,249,80,158,38,47,28,23,195,2,27,248,22,179,7,6,11,11,80,76, +133,14,249,80,158,38,47,28,23,195,2,27,248,22,185,7,6,11,11,80,76, 84,67,79,76,76,69,67,84,83,28,192,192,6,0,0,6,0,0,27,28,23, -196,1,250,22,165,13,248,22,187,13,69,97,100,100,111,110,45,100,105,114,247, -22,177,7,6,8,8,99,111,108,108,101,99,116,115,11,27,248,80,159,41,52, -36,250,22,81,23,203,1,248,22,77,248,22,187,13,72,99,111,108,108,101,99, +196,1,250,22,171,13,248,22,129,14,69,97,100,100,111,110,45,100,105,114,247, +22,183,7,6,8,8,99,111,108,108,101,99,116,115,11,27,248,80,159,41,52, +36,250,22,81,23,203,1,248,22,77,248,22,129,14,72,99,111,108,108,101,99, 116,115,45,100,105,114,23,204,1,28,193,249,22,67,195,194,192,32,47,89,162, -8,44,38,54,2,18,222,33,48,27,249,22,134,14,23,197,2,23,198,2,28, +8,44,38,54,2,18,222,33,48,27,249,22,140,14,23,197,2,23,198,2,28, 23,193,2,87,94,23,196,1,27,248,22,92,23,195,2,27,27,248,22,101,23, -197,1,27,249,22,134,14,23,201,2,23,196,2,28,23,193,2,87,94,23,194, +197,1,27,249,22,140,14,23,201,2,23,196,2,28,23,193,2,87,94,23,194, 1,27,248,22,92,23,195,2,27,250,2,47,23,203,2,23,204,1,248,22,101, -23,199,1,28,249,22,156,7,23,196,2,2,27,249,22,81,23,202,2,194,249, -22,67,248,22,156,13,23,197,1,194,87,95,23,199,1,23,193,1,28,249,22, -156,7,23,196,2,2,27,249,22,81,23,200,2,9,249,22,67,248,22,156,13, -23,197,1,9,28,249,22,156,7,23,196,2,2,27,249,22,81,197,194,87,94, -23,196,1,249,22,67,248,22,156,13,23,197,1,194,87,94,23,193,1,28,249, -22,156,7,23,198,2,2,27,249,22,81,195,9,87,94,23,194,1,249,22,67, -248,22,156,13,23,199,1,9,87,95,28,28,248,22,150,7,194,10,248,22,162, -6,194,12,250,22,135,9,2,13,6,21,21,98,121,116,101,32,115,116,114,105, +23,199,1,28,249,22,162,7,23,196,2,2,27,249,22,81,23,202,2,194,249, +22,67,248,22,162,13,23,197,1,194,87,95,23,199,1,23,193,1,28,249,22, +162,7,23,196,2,2,27,249,22,81,23,200,2,9,249,22,67,248,22,162,13, +23,197,1,9,28,249,22,162,7,23,196,2,2,27,249,22,81,197,194,87,94, +23,196,1,249,22,67,248,22,162,13,23,197,1,194,87,94,23,193,1,28,249, +22,162,7,23,198,2,2,27,249,22,81,195,9,87,94,23,194,1,249,22,67, +248,22,162,13,23,199,1,9,87,95,28,28,248,22,156,7,194,10,248,22,168, +6,194,12,250,22,141,9,2,13,6,21,21,98,121,116,101,32,115,116,114,105, 110,103,32,111,114,32,115,116,114,105,110,103,196,28,28,248,22,76,195,249,22, -4,22,147,13,196,11,12,250,22,135,9,2,13,6,13,13,108,105,115,116,32, -111,102,32,112,97,116,104,115,197,250,2,47,197,195,28,248,22,162,6,197,248, -22,173,7,197,196,32,50,89,162,8,44,39,57,2,18,222,33,53,32,51,89, +4,22,153,13,196,11,12,250,22,141,9,2,13,6,13,13,108,105,115,116,32, +111,102,32,112,97,116,104,115,197,250,2,47,197,195,28,248,22,168,6,197,248, +22,179,7,197,196,32,50,89,162,8,44,39,57,2,18,222,33,53,32,51,89, 162,8,44,38,54,70,102,111,117,110,100,45,101,120,101,99,222,33,52,28,23, -193,2,91,159,38,11,90,161,38,35,11,248,22,168,13,23,199,2,87,95,23, -195,1,23,194,1,27,28,23,198,2,27,248,22,173,13,23,201,2,28,249,22, -169,8,23,195,2,23,202,2,11,28,248,22,169,13,23,194,2,250,2,51,23, -201,2,23,202,2,249,22,165,13,23,200,2,23,198,1,250,2,51,23,201,2, +193,2,91,159,38,11,90,161,38,35,11,248,22,174,13,23,199,2,87,95,23, +195,1,23,194,1,27,28,23,198,2,27,248,22,179,13,23,201,2,28,249,22, +175,8,23,195,2,23,202,2,11,28,248,22,175,13,23,194,2,250,2,51,23, +201,2,23,202,2,249,22,171,13,23,200,2,23,198,1,250,2,51,23,201,2, 23,202,2,23,196,1,11,28,23,193,2,192,87,94,23,193,1,27,28,248,22, -147,13,23,196,2,27,249,22,165,13,23,198,2,23,201,2,28,28,248,22,160, -13,193,10,248,22,159,13,193,192,11,11,28,23,193,2,192,87,94,23,193,1, -28,23,199,2,11,27,248,22,173,13,23,202,2,28,249,22,169,8,23,195,2, -23,203,1,11,28,248,22,169,13,23,194,2,250,2,51,23,202,1,23,203,1, -249,22,165,13,23,201,1,23,198,1,250,2,51,201,202,195,194,28,248,22,75, -23,197,2,11,27,248,22,172,13,248,22,68,23,199,2,27,249,22,165,13,23, -196,1,23,197,2,28,248,22,159,13,23,194,2,250,2,51,198,199,195,87,94, +153,13,23,196,2,27,249,22,171,13,23,198,2,23,201,2,28,28,248,22,166, +13,193,10,248,22,165,13,193,192,11,11,28,23,193,2,192,87,94,23,193,1, +28,23,199,2,11,27,248,22,179,13,23,202,2,28,249,22,175,8,23,195,2, +23,203,1,11,28,248,22,175,13,23,194,2,250,2,51,23,202,1,23,203,1, +249,22,171,13,23,201,1,23,198,1,250,2,51,201,202,195,194,28,248,22,75, +23,197,2,11,27,248,22,178,13,248,22,68,23,199,2,27,249,22,171,13,23, +196,1,23,197,2,28,248,22,165,13,23,194,2,250,2,51,198,199,195,87,94, 23,193,1,27,248,22,69,23,200,1,28,248,22,75,23,194,2,11,27,248,22, -172,13,248,22,68,23,196,2,27,249,22,165,13,23,196,1,23,200,2,28,248, -22,159,13,23,194,2,250,2,51,201,202,195,87,94,23,193,1,27,248,22,69, -23,197,1,28,248,22,75,23,194,2,11,27,248,22,172,13,248,22,68,195,27, -249,22,165,13,23,196,1,202,28,248,22,159,13,193,250,2,51,204,205,195,251, -2,50,204,205,206,248,22,69,199,87,95,28,27,248,22,147,13,23,196,2,28, -23,193,2,192,87,94,23,193,1,28,248,22,162,6,23,196,2,27,248,22,169, -13,23,197,2,28,23,193,2,192,87,94,23,193,1,248,22,170,13,23,197,2, -11,12,250,22,135,9,2,14,6,25,25,112,97,116,104,32,111,114,32,115,116, +178,13,248,22,68,23,196,2,27,249,22,171,13,23,196,1,23,200,2,28,248, +22,165,13,23,194,2,250,2,51,201,202,195,87,94,23,193,1,27,248,22,69, +23,197,1,28,248,22,75,23,194,2,11,27,248,22,178,13,248,22,68,195,27, +249,22,171,13,23,196,1,202,28,248,22,165,13,193,250,2,51,204,205,195,251, +2,50,204,205,206,248,22,69,199,87,95,28,27,248,22,153,13,23,196,2,28, +23,193,2,192,87,94,23,193,1,28,248,22,168,6,23,196,2,27,248,22,175, +13,23,197,2,28,23,193,2,192,87,94,23,193,1,248,22,176,13,23,197,2, +11,12,250,22,141,9,2,14,6,25,25,112,97,116,104,32,111,114,32,115,116, 114,105,110,103,32,40,115,97,110,115,32,110,117,108,41,23,197,2,28,28,23, -195,2,28,27,248,22,147,13,23,197,2,28,23,193,2,192,87,94,23,193,1, -28,248,22,162,6,23,197,2,27,248,22,169,13,23,198,2,28,23,193,2,192, -87,94,23,193,1,248,22,170,13,23,198,2,11,248,22,169,13,23,196,2,11, -10,12,250,22,135,9,2,14,6,29,29,35,102,32,111,114,32,114,101,108,97, +195,2,28,27,248,22,153,13,23,197,2,28,23,193,2,192,87,94,23,193,1, +28,248,22,168,6,23,197,2,27,248,22,175,13,23,198,2,28,23,193,2,192, +87,94,23,193,1,248,22,176,13,23,198,2,11,248,22,175,13,23,196,2,11, +10,12,250,22,141,9,2,14,6,29,29,35,102,32,111,114,32,114,101,108,97, 116,105,118,101,32,112,97,116,104,32,111,114,32,115,116,114,105,110,103,23,198, -2,28,28,248,22,169,13,23,195,2,91,159,38,11,90,161,38,35,11,248,22, -168,13,23,198,2,249,22,167,8,194,68,114,101,108,97,116,105,118,101,11,27, -248,22,179,7,6,4,4,80,65,84,72,251,2,50,23,199,1,23,200,1,23, -201,1,28,23,197,2,27,249,80,159,43,47,37,23,200,1,9,28,249,22,167, -8,247,22,181,7,2,20,249,22,67,248,22,156,13,5,1,46,194,192,9,27, -248,22,172,13,23,196,1,28,248,22,159,13,193,250,2,51,198,199,195,11,250, +2,28,28,248,22,175,13,23,195,2,91,159,38,11,90,161,38,35,11,248,22, +174,13,23,198,2,249,22,173,8,194,68,114,101,108,97,116,105,118,101,11,27, +248,22,185,7,6,4,4,80,65,84,72,251,2,50,23,199,1,23,200,1,23, +201,1,28,23,197,2,27,249,80,159,43,47,37,23,200,1,9,28,249,22,173, +8,247,22,187,7,2,20,249,22,67,248,22,162,13,5,1,46,194,192,9,27, +248,22,178,13,23,196,1,28,248,22,165,13,193,250,2,51,198,199,195,11,250, 80,159,38,48,36,196,197,11,250,80,159,38,48,36,196,11,11,87,94,249,22, -153,6,247,22,189,4,195,248,22,179,5,249,22,174,3,35,249,22,158,3,197, +159,6,247,22,131,5,195,248,22,185,5,249,22,180,3,35,249,22,164,3,197, 198,27,28,23,197,2,87,95,23,196,1,23,195,1,23,197,1,87,94,23,197, -1,27,248,22,187,13,2,19,27,249,80,159,40,48,36,23,196,1,11,27,27, -248,22,177,3,23,200,1,28,192,192,35,27,27,248,22,177,3,23,202,1,28, -192,192,35,249,22,156,5,23,197,1,83,158,39,20,97,95,89,162,8,44,35, -47,9,224,3,2,33,57,23,195,1,23,196,1,27,248,22,141,5,23,195,1, +1,27,248,22,129,14,2,19,27,249,80,159,40,48,36,23,196,1,11,27,27, +248,22,183,3,23,200,1,28,192,192,35,27,27,248,22,183,3,23,202,1,28, +192,192,35,249,22,162,5,23,197,1,83,158,39,20,97,95,89,162,8,44,35, +47,9,224,3,2,33,57,23,195,1,23,196,1,27,248,22,147,5,23,195,1, 248,80,159,38,53,36,193,159,35,20,102,159,35,16,1,11,16,0,83,158,41, 20,100,144,67,35,37,117,116,105,108,115,29,11,11,11,11,11,10,42,80,158, 35,35,20,102,159,37,16,17,2,1,2,2,2,3,2,4,2,5,2,6,2, @@ -316,7 +316,7 @@ 83,158,35,16,2,89,162,43,36,48,2,18,223,0,33,28,80,159,35,53,36, 83,158,35,16,2,89,162,8,44,36,55,2,18,223,0,33,29,80,159,35,52, 36,83,158,35,16,2,32,0,89,162,43,36,44,2,1,222,33,30,80,159,35, -35,36,83,158,35,16,2,249,22,164,6,7,92,7,92,80,159,35,36,36,83, +35,36,83,158,35,16,2,249,22,170,6,7,92,7,92,80,159,35,36,36,83, 158,35,16,2,89,162,43,36,53,2,3,223,0,33,31,80,159,35,37,36,83, 158,35,16,2,32,0,89,162,8,44,37,49,2,4,222,33,32,80,159,35,38, 36,83,158,35,16,2,32,0,89,162,8,44,38,50,2,5,222,33,34,80,159, @@ -329,8 +329,8 @@ 11,222,33,43,80,159,35,45,36,83,158,35,16,2,83,158,38,20,96,96,2, 12,89,162,43,35,43,9,223,0,33,44,89,162,43,36,44,9,223,0,33,45, 89,162,43,37,54,9,223,0,33,46,80,159,35,46,36,83,158,35,16,2,27, -248,22,130,14,248,22,173,7,27,28,249,22,167,8,247,22,181,7,2,20,6, -1,1,59,6,1,1,58,250,22,146,7,6,14,14,40,91,94,126,97,93,42, +248,22,136,14,248,22,179,7,27,28,249,22,173,8,247,22,187,7,2,20,6, +1,1,59,6,1,1,58,250,22,152,7,6,14,14,40,91,94,126,97,93,42, 41,126,97,40,46,42,41,23,196,2,23,196,1,89,162,8,44,37,47,2,13, 223,0,33,49,80,159,35,47,36,83,158,35,16,2,83,158,38,20,96,96,2, 14,89,162,8,44,38,53,9,223,0,33,54,89,162,43,37,46,9,223,0,33, @@ -341,12 +341,12 @@ EVAL_ONE_SIZED_STR((char *)expr, 5006); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,51,46,50,8,0,0,0,1,0,0,6,0,19,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,51,46,52,8,0,0,0,1,0,0,6,0,19,0, 34,0,48,0,62,0,76,0,118,0,0,0,38,1,0,0,65,113,117,111,116, 101,29,94,2,1,67,35,37,117,116,105,108,115,11,29,94,2,1,69,35,37, 110,101,116,119,111,114,107,11,29,94,2,1,68,35,37,112,97,114,97,109,122, 11,29,94,2,1,68,35,37,101,120,112,111,98,115,11,29,94,2,1,68,35, -37,107,101,114,110,101,108,11,97,35,11,8,240,46,71,0,0,98,159,2,2, +37,107,101,114,110,101,108,11,97,35,11,8,240,169,79,0,0,98,159,2,2, 35,35,159,2,3,35,35,159,2,4,35,35,159,2,5,35,35,159,2,6,35, 35,159,2,6,35,35,16,0,159,35,20,102,159,35,16,1,11,16,0,83,158, 41,20,100,144,69,35,37,98,117,105,108,116,105,110,29,11,11,11,11,11,18, @@ -360,7 +360,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 331); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,51,46,50,56,0,0,0,1,0,0,11,0,38,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,51,46,52,56,0,0,0,1,0,0,11,0,38,0, 44,0,57,0,66,0,73,0,95,0,117,0,143,0,155,0,173,0,193,0,205, 0,221,0,244,0,0,1,31,1,38,1,43,1,48,1,53,1,58,1,67,1, 72,1,76,1,84,1,93,1,101,1,204,1,249,1,13,2,42,2,73,2,129, @@ -383,48 +383,48 @@ 29,94,2,3,2,5,11,64,98,111,111,116,64,115,101,97,108,64,115,97,109, 101,5,3,46,122,111,6,6,6,110,97,116,105,118,101,64,108,111,111,112,63, 108,105,98,67,105,103,110,111,114,101,100,249,22,14,195,80,159,37,45,37,249, -80,159,37,48,36,195,10,27,28,23,195,2,28,249,22,167,8,23,197,2,80, -158,38,46,87,94,23,195,1,80,158,36,47,27,248,22,176,4,23,197,2,28, -248,22,147,13,23,194,2,91,159,38,11,90,161,38,35,11,248,22,168,13,23, +80,159,37,48,36,195,10,27,28,23,195,2,28,249,22,173,8,23,197,2,80, +158,38,46,87,94,23,195,1,80,158,36,47,27,248,22,182,4,23,197,2,28, +248,22,153,13,23,194,2,91,159,38,11,90,161,38,35,11,248,22,174,13,23, 197,1,87,95,83,160,37,11,80,158,40,46,198,83,160,37,11,80,158,40,47, -192,192,11,11,28,23,193,2,192,87,94,23,193,1,27,247,22,130,5,28,192, -192,247,22,188,13,20,14,159,80,158,35,39,250,80,158,38,40,249,22,27,11, -80,158,40,39,22,130,5,28,248,22,147,13,23,198,2,23,197,1,87,94,23, -197,1,247,22,188,13,247,194,250,22,165,13,23,197,1,23,199,1,249,80,158, -42,38,23,198,1,2,22,252,22,165,13,23,199,1,23,201,1,2,23,247,22, -182,7,249,80,158,44,38,23,200,1,80,159,44,35,37,87,94,23,194,1,27, -250,22,182,13,196,11,32,0,89,162,8,44,35,40,9,222,11,28,192,249,22, -67,195,194,11,27,252,22,165,13,23,200,1,23,202,1,2,23,247,22,182,7, -249,80,158,45,38,23,201,1,80,159,45,35,37,27,250,22,182,13,196,11,32, +192,192,11,11,28,23,193,2,192,87,94,23,193,1,27,247,22,136,5,28,192, +192,247,22,130,14,20,14,159,80,158,35,39,250,80,158,38,40,249,22,27,11, +80,158,40,39,22,136,5,28,248,22,153,13,23,198,2,23,197,1,87,94,23, +197,1,247,22,130,14,247,194,250,22,171,13,23,197,1,23,199,1,249,80,158, +42,38,23,198,1,2,22,252,22,171,13,23,199,1,23,201,1,2,23,247,22, +188,7,249,80,158,44,38,23,200,1,80,159,44,35,37,87,94,23,194,1,27, +250,22,188,13,196,11,32,0,89,162,8,44,35,40,9,222,11,28,192,249,22, +67,195,194,11,27,252,22,171,13,23,200,1,23,202,1,2,23,247,22,188,7, +249,80,158,45,38,23,201,1,80,159,45,35,37,27,250,22,188,13,196,11,32, 0,89,162,8,44,35,40,9,222,11,28,192,249,22,67,195,194,11,249,247,22, -129,14,248,22,68,195,195,27,250,22,165,13,23,198,1,23,200,1,249,80,158, -43,38,23,199,1,2,22,27,250,22,182,13,196,11,32,0,89,162,8,44,35, -40,9,222,11,28,192,249,22,67,195,194,11,249,247,22,128,5,248,22,68,195, -195,249,247,22,128,5,194,195,87,94,28,248,80,158,36,37,23,195,2,12,250, -22,135,9,77,108,111,97,100,47,117,115,101,45,99,111,109,112,105,108,101,100, +135,14,248,22,68,195,195,27,250,22,171,13,23,198,1,23,200,1,249,80,158, +43,38,23,199,1,2,22,27,250,22,188,13,196,11,32,0,89,162,8,44,35, +40,9,222,11,28,192,249,22,67,195,194,11,249,247,22,134,5,248,22,68,195, +195,249,247,22,134,5,194,195,87,94,28,248,80,158,36,37,23,195,2,12,250, +22,141,9,77,108,111,97,100,47,117,115,101,45,99,111,109,112,105,108,101,100, 6,25,25,112,97,116,104,32,111,114,32,118,97,108,105,100,45,112,97,116,104, 32,115,116,114,105,110,103,23,197,2,91,159,41,11,90,161,36,35,11,28,248, -22,171,13,23,201,2,23,200,1,27,247,22,130,5,28,23,193,2,249,22,172, -13,23,203,1,23,195,1,200,90,161,38,36,11,248,22,168,13,23,194,2,87, -94,23,196,1,90,161,36,39,11,28,249,22,167,8,23,196,2,68,114,101,108, +22,177,13,23,201,2,23,200,1,27,247,22,136,5,28,23,193,2,249,22,178, +13,23,203,1,23,195,1,200,90,161,38,36,11,248,22,174,13,23,194,2,87, +94,23,196,1,90,161,36,39,11,28,249,22,173,8,23,196,2,68,114,101,108, 97,116,105,118,101,87,94,23,194,1,2,21,23,194,1,90,161,36,40,11,247, -22,190,13,27,89,162,43,36,49,62,122,111,225,7,5,3,33,31,27,89,162, +22,132,14,27,89,162,43,36,49,62,122,111,225,7,5,3,33,31,27,89,162, 43,36,51,9,225,8,6,4,33,32,27,249,22,5,89,162,8,44,36,46,9, 223,5,33,33,23,203,2,27,28,23,195,1,27,249,22,5,89,162,8,44,36, 52,9,225,13,11,9,33,34,23,205,2,27,28,23,196,2,11,193,28,192,192, -28,193,28,23,196,2,28,249,22,170,3,248,22,69,196,248,22,69,23,199,2, +28,193,28,23,196,2,28,249,22,176,3,248,22,69,196,248,22,69,23,199,2, 193,11,11,11,11,28,23,193,2,249,80,159,47,58,36,202,89,162,43,35,45, 9,224,14,2,33,35,87,94,23,193,1,27,28,23,197,1,27,249,22,5,83, 158,39,20,97,94,89,162,8,44,36,50,9,225,14,12,10,33,36,23,203,1, -23,206,1,27,28,196,11,193,28,192,192,28,193,28,196,28,249,22,170,3,248, +23,206,1,27,28,196,11,193,28,192,192,28,193,28,196,28,249,22,176,3,248, 22,69,196,248,22,69,199,193,11,11,11,11,28,192,249,80,159,48,58,36,203, 89,162,43,35,45,9,224,15,2,33,37,249,80,159,48,58,36,203,89,162,43, 35,44,9,224,15,7,33,38,32,40,89,162,8,44,36,54,2,24,222,33,42, 0,17,35,114,120,34,94,40,46,42,63,41,47,40,46,42,41,36,34,27,249, -22,134,14,2,41,23,196,2,28,23,193,2,87,94,23,194,1,249,22,67,248, -22,92,23,196,2,27,248,22,101,23,197,1,27,249,22,134,14,2,41,23,196, +22,140,14,2,41,23,196,2,28,23,193,2,87,94,23,194,1,249,22,67,248, +22,92,23,196,2,27,248,22,101,23,197,1,27,249,22,140,14,2,41,23,196, 2,28,23,193,2,87,94,23,194,1,249,22,67,248,22,92,23,196,2,27,248, -22,101,23,197,1,27,249,22,134,14,2,41,23,196,2,28,23,193,2,87,94, +22,101,23,197,1,27,249,22,140,14,2,41,23,196,2,28,23,193,2,87,94, 23,194,1,249,22,67,248,22,92,23,196,2,248,2,40,248,22,101,23,197,1, 248,22,77,194,248,22,77,194,248,22,77,194,32,43,89,162,43,36,54,2,24, 222,33,44,28,248,22,75,248,22,69,23,195,2,249,22,7,9,248,22,68,195, @@ -434,95 +434,95 @@ 195,91,159,37,11,90,161,37,35,11,248,2,43,248,22,69,196,249,22,7,249, 22,67,248,22,68,199,196,195,249,22,7,249,22,67,248,22,68,199,196,195,249, 22,7,249,22,67,248,22,68,199,196,195,27,248,2,40,23,195,1,28,194,192, -248,2,43,193,87,95,28,248,22,174,4,195,12,250,22,135,9,2,17,6,20, +248,2,43,193,87,95,28,248,22,180,4,195,12,250,22,141,9,2,17,6,20, 20,114,101,115,111,108,118,101,100,45,109,111,100,117,108,101,45,112,97,116,104, 197,28,24,193,2,248,24,194,1,195,87,94,23,193,1,12,27,27,250,22,141, -2,80,159,41,42,37,248,22,154,14,247,22,129,12,11,28,23,193,2,192,87, +2,80,159,41,42,37,248,22,160,14,247,22,135,12,11,28,23,193,2,192,87, 94,23,193,1,27,247,22,125,87,94,250,22,139,2,80,159,42,42,37,248,22, -154,14,247,22,129,12,195,192,250,22,139,2,195,198,66,97,116,116,97,99,104, -251,211,197,198,199,10,28,192,250,22,134,9,11,196,195,248,22,132,9,194,28, -249,22,168,6,194,6,1,1,46,2,21,28,249,22,168,6,194,6,2,2,46, -46,62,117,112,192,28,249,22,169,8,248,22,69,23,200,2,23,197,1,28,249, -22,167,8,248,22,68,23,200,2,23,196,1,251,22,132,9,2,17,6,26,26, +160,14,247,22,135,12,195,192,250,22,139,2,195,198,66,97,116,116,97,99,104, +251,211,197,198,199,10,28,192,250,22,140,9,11,196,195,248,22,138,9,194,28, +249,22,174,6,194,6,1,1,46,2,21,28,249,22,174,6,194,6,2,2,46, +46,62,117,112,192,28,249,22,175,8,248,22,69,23,200,2,23,197,1,28,249, +22,173,8,248,22,68,23,200,2,23,196,1,251,22,138,9,2,17,6,26,26, 99,121,99,108,101,32,105,110,32,108,111,97,100,105,110,103,32,97,116,32,126, 101,58,32,126,101,23,200,1,249,22,2,22,69,248,22,82,249,22,67,23,206, 1,23,202,1,12,12,247,192,20,14,159,80,159,39,44,37,249,22,67,248,22, -154,14,247,22,129,12,23,197,1,20,14,159,80,158,39,39,250,80,158,42,40, -249,22,27,11,80,158,44,39,22,156,4,23,196,1,249,247,22,129,5,23,198, -1,248,22,55,248,22,151,13,23,198,1,87,94,28,28,248,22,147,13,23,196, -2,10,248,22,180,4,23,196,2,12,28,23,197,2,250,22,134,9,11,6,15, +160,14,247,22,135,12,23,197,1,20,14,159,80,158,39,39,250,80,158,42,40, +249,22,27,11,80,158,44,39,22,162,4,23,196,1,249,247,22,135,5,23,198, +1,248,22,55,248,22,157,13,23,198,1,87,94,28,28,248,22,153,13,23,196, +2,10,248,22,186,4,23,196,2,12,28,23,197,2,250,22,140,9,11,6,15, 15,98,97,100,32,109,111,100,117,108,101,32,112,97,116,104,23,200,2,250,22, -135,9,2,17,6,19,19,109,111,100,117,108,101,45,112,97,116,104,32,111,114, -32,112,97,116,104,23,198,2,28,28,248,22,65,23,196,2,249,22,167,8,248, -22,68,23,198,2,2,3,11,248,22,175,4,248,22,92,196,28,28,248,22,65, -23,196,2,249,22,167,8,248,22,68,23,198,2,66,112,108,97,110,101,116,11, +141,9,2,17,6,19,19,109,111,100,117,108,101,45,112,97,116,104,32,111,114, +32,112,97,116,104,23,198,2,28,28,248,22,65,23,196,2,249,22,173,8,248, +22,68,23,198,2,2,3,11,248,22,181,4,248,22,92,196,28,28,248,22,65, +23,196,2,249,22,173,8,248,22,68,23,198,2,66,112,108,97,110,101,116,11, 87,94,28,207,12,20,14,159,80,158,36,51,80,158,36,49,90,161,36,35,10, -249,22,157,4,21,94,2,25,6,18,18,112,108,97,110,101,116,47,114,101,115, +249,22,163,4,21,94,2,25,6,18,18,112,108,97,110,101,116,47,114,101,115, 111,108,118,101,114,46,115,115,1,27,112,108,97,110,101,116,45,109,111,100,117, 108,101,45,110,97,109,101,45,114,101,115,111,108,118,101,114,12,252,212,199,200, 201,202,80,158,41,49,87,94,23,193,1,27,89,162,8,44,36,45,79,115,104, 111,119,45,99,111,108,108,101,99,116,105,111,110,45,101,114,114,223,5,33,48, 27,28,248,22,53,23,198,2,27,250,22,141,2,80,159,42,43,37,249,22,67, -23,203,2,247,22,189,13,11,28,23,193,2,192,87,94,23,193,1,91,159,37, +23,203,2,247,22,131,14,11,28,23,193,2,192,87,94,23,193,1,91,159,37, 11,90,161,37,35,11,249,80,159,43,48,36,248,22,58,23,203,2,11,27,251, 80,158,46,52,2,17,23,202,1,28,248,22,75,23,199,2,23,199,2,248,22, -68,23,199,2,28,248,22,75,23,199,2,9,248,22,69,23,199,2,249,22,165, +68,23,199,2,28,248,22,75,23,199,2,9,248,22,69,23,199,2,249,22,171, 13,23,195,1,28,248,22,75,23,197,1,87,94,23,197,1,6,7,7,109,97, -105,110,46,115,115,249,22,185,6,23,199,1,6,3,3,46,115,115,28,248,22, -162,6,23,198,2,87,94,23,194,1,27,248,80,159,40,59,36,23,200,2,27, +105,110,46,115,115,249,22,191,6,23,199,1,6,3,3,46,115,115,28,248,22, +168,6,23,198,2,87,94,23,194,1,27,248,80,159,40,59,36,23,200,2,27, 250,22,141,2,80,159,43,43,37,249,22,67,23,204,2,23,199,2,11,28,23, 193,2,192,87,94,23,193,1,91,159,37,11,90,161,37,35,11,249,80,159,44, -48,36,23,203,2,11,250,22,1,22,165,13,23,199,1,249,22,81,249,22,2, +48,36,23,203,2,11,250,22,1,22,171,13,23,199,1,249,22,81,249,22,2, 32,0,89,162,8,44,36,43,9,222,33,49,23,200,1,248,22,77,23,200,1, -28,248,22,147,13,23,198,2,87,94,23,194,1,28,248,22,170,13,23,198,2, +28,248,22,153,13,23,198,2,87,94,23,194,1,28,248,22,176,13,23,198,2, 23,197,2,248,22,77,6,26,26,32,40,97,32,112,97,116,104,32,109,117,115, -116,32,98,101,32,97,98,115,111,108,117,116,101,41,28,249,22,167,8,248,22, +116,32,98,101,32,97,98,115,111,108,117,116,101,41,28,249,22,173,8,248,22, 68,23,200,2,2,25,27,250,22,141,2,80,159,42,43,37,249,22,67,23,203, -2,247,22,189,13,11,28,23,193,2,192,87,94,23,193,1,91,159,38,11,90, +2,247,22,131,14,11,28,23,193,2,192,87,94,23,193,1,91,159,38,11,90, 161,37,35,11,249,80,159,44,48,36,248,22,92,23,204,2,11,90,161,36,37, -11,28,248,22,75,248,22,94,23,203,2,28,248,22,75,23,194,2,249,22,136, +11,28,248,22,75,248,22,94,23,203,2,28,248,22,75,23,194,2,249,22,142, 14,0,8,35,114,120,34,91,46,93,34,23,196,2,11,10,27,27,28,23,197, 2,249,22,81,28,248,22,75,248,22,94,23,207,2,21,93,6,5,5,109,122, 108,105,98,249,22,1,22,81,249,22,2,80,159,50,8,25,36,248,22,94,23, 210,2,23,197,2,28,248,22,75,23,196,2,248,22,77,23,197,2,23,195,2, 251,80,158,48,52,2,17,23,204,1,248,22,68,23,198,2,248,22,69,23,198, -1,249,22,165,13,23,195,1,28,23,198,1,87,94,23,196,1,23,197,1,28, +1,249,22,171,13,23,195,1,28,23,198,1,87,94,23,196,1,23,197,1,28, 248,22,75,23,197,1,87,94,23,197,1,6,7,7,109,97,105,110,46,115,115, -28,249,22,136,14,0,8,35,114,120,34,91,46,93,34,23,199,2,23,197,1, -249,22,185,6,23,199,1,6,3,3,46,115,115,28,249,22,167,8,248,22,68, -23,200,2,64,102,105,108,101,249,22,172,13,248,22,176,13,248,22,92,23,201, -2,248,80,159,41,59,36,23,201,2,12,87,94,28,28,248,22,147,13,23,194, -2,10,248,22,184,7,23,194,2,87,94,23,199,1,12,28,23,199,2,250,22, -134,9,67,114,101,113,117,105,114,101,249,22,146,7,6,17,17,98,97,100,32, +28,249,22,142,14,0,8,35,114,120,34,91,46,93,34,23,199,2,23,197,1, +249,22,191,6,23,199,1,6,3,3,46,115,115,28,249,22,173,8,248,22,68, +23,200,2,64,102,105,108,101,249,22,178,13,248,22,182,13,248,22,92,23,201, +2,248,80,159,41,59,36,23,201,2,12,87,94,28,28,248,22,153,13,23,194, +2,10,248,22,190,7,23,194,2,87,94,23,199,1,12,28,23,199,2,250,22, +140,9,67,114,101,113,117,105,114,101,249,22,152,7,6,17,17,98,97,100,32, 109,111,100,117,108,101,32,112,97,116,104,126,97,28,23,198,2,248,22,68,23, -199,2,6,0,0,23,202,1,87,94,23,199,1,250,22,135,9,2,17,249,22, -146,7,6,13,13,109,111,100,117,108,101,32,112,97,116,104,126,97,28,23,198, -2,248,22,68,23,199,2,6,0,0,23,200,2,27,28,248,22,184,7,23,195, -2,249,22,189,7,23,196,2,35,249,22,174,13,248,22,175,13,23,197,2,11, -27,28,248,22,184,7,23,196,2,249,22,189,7,23,197,2,36,248,80,158,41, -53,23,195,2,91,159,38,11,90,161,38,35,11,28,248,22,184,7,23,199,2, -250,22,7,2,26,249,22,189,7,23,203,2,37,2,26,248,22,168,13,23,198, -2,87,95,23,195,1,23,193,1,27,28,248,22,184,7,23,200,2,249,22,189, -7,23,201,2,38,249,80,158,46,54,23,197,2,5,0,27,28,248,22,184,7, -23,201,2,249,22,189,7,23,202,2,39,248,22,175,4,23,200,2,27,27,250, -22,141,2,80,159,50,42,37,248,22,154,14,247,22,129,12,11,28,23,193,2, +199,2,6,0,0,23,202,1,87,94,23,199,1,250,22,141,9,2,17,249,22, +152,7,6,13,13,109,111,100,117,108,101,32,112,97,116,104,126,97,28,23,198, +2,248,22,68,23,199,2,6,0,0,23,200,2,27,28,248,22,190,7,23,195, +2,249,22,131,8,23,196,2,35,249,22,180,13,248,22,181,13,23,197,2,11, +27,28,248,22,190,7,23,196,2,249,22,131,8,23,197,2,36,248,80,158,41, +53,23,195,2,91,159,38,11,90,161,38,35,11,28,248,22,190,7,23,199,2, +250,22,7,2,26,249,22,131,8,23,203,2,37,2,26,248,22,174,13,23,198, +2,87,95,23,195,1,23,193,1,27,28,248,22,190,7,23,200,2,249,22,131, +8,23,201,2,38,249,80,158,46,54,23,197,2,5,0,27,28,248,22,190,7, +23,201,2,249,22,131,8,23,202,2,39,248,22,181,4,23,200,2,27,27,250, +22,141,2,80,159,50,42,37,248,22,160,14,247,22,135,12,11,28,23,193,2, 192,87,94,23,193,1,27,247,22,125,87,94,250,22,139,2,80,159,51,42,37, -248,22,154,14,247,22,129,12,195,192,87,95,28,23,208,1,27,250,22,141,2, +248,22,160,14,247,22,135,12,195,192,87,95,28,23,208,1,27,250,22,141,2, 23,197,2,197,11,28,23,193,1,12,87,95,27,27,28,248,22,17,80,159,50, 45,37,80,159,49,45,37,247,22,19,250,22,25,248,22,23,23,197,2,80,159, -52,44,37,23,196,1,27,248,22,154,14,247,22,129,12,249,22,3,83,158,39, +52,44,37,23,196,1,27,248,22,160,14,247,22,135,12,249,22,3,83,158,39, 20,97,94,89,162,8,44,36,54,9,226,12,11,2,3,33,50,23,195,1,23, 196,1,248,28,248,22,17,80,159,49,45,37,32,0,89,162,43,36,41,9,222, 33,51,80,159,48,8,26,36,89,162,43,35,50,9,227,13,9,8,4,3,33, -52,250,22,139,2,23,197,1,197,10,12,28,28,248,22,184,7,23,202,1,11, -27,248,22,162,6,23,207,2,28,192,192,27,248,22,53,23,208,2,28,192,192, -28,248,22,65,23,208,2,249,22,167,8,248,22,68,23,210,2,2,25,11,250, -22,139,2,80,159,49,43,37,28,248,22,162,6,23,209,2,249,22,67,23,210, +52,250,22,139,2,23,197,1,197,10,12,28,28,248,22,190,7,23,202,1,11, +27,248,22,168,6,23,207,2,28,192,192,27,248,22,53,23,208,2,28,192,192, +28,248,22,65,23,208,2,249,22,173,8,248,22,68,23,210,2,2,25,11,250, +22,139,2,80,159,49,43,37,28,248,22,168,6,23,209,2,249,22,67,23,210, 1,248,80,159,52,59,36,23,212,1,87,94,23,209,1,249,22,67,23,210,1, -247,22,189,13,252,22,186,7,23,208,1,23,207,1,23,205,1,23,203,1,201, +247,22,131,14,252,22,128,8,23,208,1,23,207,1,23,205,1,23,203,1,201, 12,193,87,96,83,160,37,11,80,158,35,49,248,80,158,36,57,249,22,27,11, -80,158,38,51,248,22,155,4,80,159,36,50,37,248,22,129,5,80,159,36,36, -36,248,22,184,12,80,159,36,41,36,83,160,37,11,80,158,35,49,248,80,158, +80,158,38,51,248,22,161,4,80,159,36,50,37,248,22,135,5,80,159,36,36, +36,248,22,190,12,80,159,36,41,36,83,160,37,11,80,158,35,49,248,80,158, 36,57,249,22,27,11,80,158,38,51,159,35,20,102,159,35,16,1,11,16,0, 83,158,41,20,100,144,66,35,37,98,111,111,116,29,11,11,11,11,11,10,37, 80,158,35,35,20,102,159,39,16,23,2,1,2,2,30,2,4,72,112,97,116, @@ -543,7 +543,7 @@ 0,33,28,80,159,35,8,25,36,83,158,35,16,2,89,162,43,36,48,67,103, 101,116,45,100,105,114,223,0,33,29,80,159,35,59,36,83,158,35,16,2,89, 162,43,37,48,68,119,105,116,104,45,100,105,114,223,0,33,30,80,159,35,58, -36,83,158,35,16,2,248,22,181,7,69,115,111,45,115,117,102,102,105,120,80, +36,83,158,35,16,2,248,22,187,7,69,115,111,45,115,117,102,102,105,120,80, 159,35,35,36,83,158,35,16,2,89,162,43,37,59,2,2,223,0,33,39,80, 159,35,36,36,83,158,35,16,2,32,0,89,162,8,44,36,41,2,8,222,192, 80,159,35,41,36,83,158,35,16,2,247,22,128,2,80,159,35,42,36,83,158, diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index 8336e4776e..1eb4d678ce 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -182,6 +182,8 @@ static void init_compile_data(Scheme_Comp_Env *env); #define ASSERT_IS_VARIABLE_BUCKET(b) /* if (((Scheme_Object *)b)->type != scheme_variable_type) abort() */ +static Scheme_Object *unshadowable_symbol; + /*========================================================================*/ /* initialization */ /*========================================================================*/ @@ -354,8 +356,10 @@ Scheme_Env *scheme_engine_instance_init() { #endif #if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES) + scheme_places_block_child_signal(); + GC_switch_out_master_gc(); - spawn_master_scheme_place(); + scheme_spawn_master_place(); #endif place_instance_init_pre_kernel(stack_base); @@ -363,6 +367,14 @@ Scheme_Env *scheme_engine_instance_init() { scheme_init_parameterization_readonly_globals(); env = place_instance_init_post_kernel(1); +#if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES) +{ + int *signal_fd; + signal_fd = scheme_get_signal_handle(); + GC_set_put_external_event_fd(signal_fd); +} +#endif + return env; } @@ -496,8 +508,19 @@ static Scheme_Env *place_instance_init_post_kernel(int initial_main_os_thread) { } Scheme_Env *scheme_place_instance_init(void *stack_base) { + Scheme_Env *env; +#if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES) + int *signal_fd; + GC_construct_child_gc(); +#endif place_instance_init_pre_kernel(stack_base); - return place_instance_init_post_kernel(0); + env = place_instance_init_post_kernel(0); +#if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES) + signal_fd = scheme_get_signal_handle(); + GC_set_put_external_event_fd(signal_fd); +#endif + scheme_set_can_break(1); + return env; } void scheme_place_instance_destroy() { @@ -632,6 +655,9 @@ static void make_kernel_env(void) scheme_current_thread->name = sym; } + REGISTER_SO(unshadowable_symbol); + unshadowable_symbol = scheme_intern_symbol("unshadowable"); + DONE_TIME(env); scheme_install_type_writer(scheme_toplevel_type, write_toplevel); @@ -4386,7 +4412,7 @@ do_local_exp_time_value(const char *name, int argc, Scheme_Object *argv[], int r Scheme_Comp_Env *stx_env; if (!SAME_TYPE(scheme_intdef_context_type, SCHEME_TYPE(argv[2]))) scheme_wrong_type(name, "internal-definition context or #f", 2, argc, argv); - stx_env = (Scheme_Comp_Env *)SCHEME_PTR1_VAL(argv[2]); + stx_env = (Scheme_Comp_Env *)((void **)SCHEME_PTR1_VAL(argv[2]))[0]; if (!scheme_is_sub_env(stx_env, env)) { scheme_raise_exn(MZEXN_FAIL_CONTRACT, "%s: transforming context does " "not match given internal-definition context", @@ -4687,7 +4713,7 @@ static Scheme_Object * local_get_shadower(int argc, Scheme_Object *argv[]) { Scheme_Comp_Env *env, *frame; - Scheme_Object *sym, *esym, *sym_marks = NULL, *orig_sym, *uid = NULL, *env_marks; + Scheme_Object *sym, *esym, *sym_marks = NULL, *orig_sym, *uid = NULL, *env_marks, *prop; env = scheme_current_thread->current_local_env; if (!env) @@ -4712,16 +4738,19 @@ local_get_shadower(int argc, Scheme_Object *argv[]) for (i = frame->num_bindings; i--; ) { if (frame->values[i]) { if (SAME_OBJ(SCHEME_STX_VAL(sym), SCHEME_STX_VAL(frame->values[i]))) { - esym = frame->values[i]; - env_marks = scheme_stx_extract_marks(esym); - if (scheme_equal(env_marks, sym_marks)) { - sym = esym; - if (frame->uids) - uid = frame->uids[i]; - else - uid = frame->uid; - break; - } + prop = scheme_stx_property(frame->values[i], unshadowable_symbol, NULL); + if (SCHEME_FALSEP(prop)) { + esym = frame->values[i]; + env_marks = scheme_stx_extract_marks(esym); + if (scheme_equal(env_marks, sym_marks)) { + sym = esym; + if (frame->uids) + uid = frame->uids[i]; + else + uid = frame->uid; + break; + } + } } } } @@ -4734,14 +4763,17 @@ local_get_shadower(int argc, Scheme_Object *argv[]) if (SAME_OBJ(SCHEME_STX_VAL(sym), SCHEME_STX_VAL(COMPILE_DATA(frame)->const_names[i]))) { esym = COMPILE_DATA(frame)->const_names[i]; - env_marks = scheme_stx_extract_marks(esym); - if (scheme_equal(env_marks, sym_marks)) { /* This used to have 1 || --- why? */ - sym = esym; - if (COMPILE_DATA(frame)->const_uids) - uid = COMPILE_DATA(frame)->const_uids[i]; - else - uid = frame->uid; - break; + prop = scheme_stx_property(esym, unshadowable_symbol, NULL); + if (SCHEME_FALSEP(prop)) { + env_marks = scheme_stx_extract_marks(esym); + if (scheme_equal(env_marks, sym_marks)) { /* This used to have 1 || --- why? */ + sym = esym; + if (COMPILE_DATA(frame)->const_uids) + uid = COMPILE_DATA(frame)->const_uids[i]; + else + uid = frame->uid; + break; + } } } } diff --git a/src/mzscheme/src/file.c b/src/mzscheme/src/file.c index ef2652bfc0..a056c3556b 100644 --- a/src/mzscheme/src/file.c +++ b/src/mzscheme/src/file.c @@ -227,7 +227,8 @@ static Scheme_Object *init_dir_symbol, *init_file_symbol, *sys_dir_symbol; static Scheme_Object *exec_file_symbol, *run_file_symbol, *collects_dir_symbol; static Scheme_Object *pref_file_symbol, *orig_dir_symbol, *addon_dir_symbol; -static Scheme_Object *exec_cmd, *run_cmd, *collects_path, *original_pwd; +static Scheme_Object *exec_cmd, *run_cmd; +static Scheme_Object *collects_path, *original_pwd = NULL, *addon_dir = NULL; #endif static Scheme_Object *windows_symbol, *unix_symbol; @@ -5734,6 +5735,7 @@ find_system_path(int argc, Scheme_Object **argv) } else if (argv[0] == orig_dir_symbol) { return original_pwd; } else if (argv[0] == addon_dir_symbol) { + if (addon_dir) return addon_dir; which = id_addon_dir; } else { scheme_wrong_type("find-system-path", "system-path-symbol", @@ -6023,6 +6025,14 @@ void scheme_set_original_dir(Scheme_Object *d) original_pwd = d; } +void scheme_set_addon_dir(Scheme_Object *p) +{ + if (!addon_dir) { + REGISTER_SO(addon_dir); + } + addon_dir = p; +} + /********************************************************************************/ #ifdef DOS_FILE_SYSTEM diff --git a/src/mzscheme/src/fun.c b/src/mzscheme/src/fun.c index 6354dbaeb0..da5af9f491 100644 --- a/src/mzscheme/src/fun.c +++ b/src/mzscheme/src/fun.c @@ -3661,13 +3661,16 @@ static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[]) static Scheme_Object *procedure_rename(int argc, Scheme_Object *argv[]) { - Scheme_Object *aty; + Scheme_Object *p, *aty; if (!SCHEME_PROCP(argv[0])) scheme_wrong_type("procedure-rename", "procedure", 0, argc, argv); if (!SCHEME_SYMBOLP(argv[1])) scheme_wrong_type("procedure-rename", "symbol", 1, argc, argv); + p = scheme_rename_struct_proc(argv[0], argv[1]); + if (p) return p; + aty = get_or_check_arity(argv[0], -1, NULL); return make_reduced_proc(argv[0], aty, argv[1]); diff --git a/src/mzscheme/src/future.c b/src/mzscheme/src/future.c index 4cd5930ec5..bdf43c12d3 100644 --- a/src/mzscheme/src/future.c +++ b/src/mzscheme/src/future.c @@ -139,7 +139,7 @@ void scheme_init_futures(Scheme_Env *env) FUTURE_PRIM_W_ARITY("future?", future_p, 1, 1, newenv); FUTURE_PRIM_W_ARITY("future", future, 1, 1, newenv); FUTURE_PRIM_W_ARITY("touch", touch, 1, 1, newenv); - FUTURE_PRIM_W_ARITY("processor-count", processor_count, 1, 1, newenv); + FUTURE_PRIM_W_ARITY("processor-count", processor_count, 0, 0, newenv); scheme_finish_primitive_module(newenv); scheme_protect_primitive_provide(newenv, NULL); @@ -163,6 +163,7 @@ static void init_future_thread(struct Scheme_Future_State *fs, int i); #define THREAD_POOL_SIZE 12 #define INITIAL_C_STACK_SIZE 500000 +#define FUTURE_RUNSTACK_SIZE 1000 typedef struct Scheme_Future_State { struct Scheme_Future_Thread_State *pool_threads[THREAD_POOL_SIZE]; @@ -397,7 +398,7 @@ static void init_future_thread(Scheme_Future_State *fs, int i) { Scheme_Object **rs_start, **rs; - long init_runstack_size = 1000; + long init_runstack_size = FUTURE_RUNSTACK_SIZE; rs_start = scheme_alloc_runstack(init_runstack_size); rs = rs_start XFORM_OK_PLUS init_runstack_size; params.runstack_start = rs_start; @@ -565,6 +566,11 @@ Scheme_Object *future(int argc, Scheme_Object *argv[]) scheme_on_demand_generate_lambda(nc, 0, NULL); } + if (ncd->max_let_depth > FUTURE_RUNSTACK_SIZE * sizeof(void*)) { + /* Can't even call it in a future thread */ + ft->status = PENDING_OVERSIZE; + } + ft->code = (void*)ncd->code; pthread_mutex_lock(&fs->future_mutex); @@ -631,7 +637,11 @@ Scheme_Object *touch(int argc, Scheme_Object *argv[]) #endif pthread_mutex_lock(&fs->future_mutex); - if (ft->status == PENDING) { + if ((ft->status == PENDING) || (ft->status == PENDING_OVERSIZE)) { + if (ft->status == PENDING_OVERSIZE) { + scheme_log(scheme_main_logger, SCHEME_LOG_DEBUG, 0, + "future: oversize procedure deferred to runtime thread"); + } ft->status = RUNNING; pthread_mutex_unlock(&fs->future_mutex); @@ -820,7 +830,9 @@ void *worker_thread_future_loop(void *arg) //including runtime calls. //If jitcode asks the runrtime thread to do work, then //a GC can occur. - LOG("Running JIT code at %p...\n", ft->code); + LOG("Running JIT code at %p...\n", ft->code); + + MZ_RUNSTACK = MZ_RUNSTACK_START + fts->runstack_size; scheme_current_thread->error_buf = &newbuf; if (scheme_future_setjmp(newbuf)) { diff --git a/src/mzscheme/src/future.h b/src/mzscheme/src/future.h index a2c8eee44e..e1bad68ffe 100644 --- a/src/mzscheme/src/future.h +++ b/src/mzscheme/src/future.h @@ -34,6 +34,7 @@ typedef void* (*prim_pvoid_pvoid_pvoid_t)(void*, void*); #define RUNNING 1 #define WAITING_FOR_PRIM 2 #define FINISHED 3 +#define PENDING_OVERSIZE 4 #define FSRC_OTHER 0 #define FSRC_RATOR 1 diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index 95859ffeb2..a845e2b62b 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -88,6 +88,8 @@ END_XFORM_ARITH; #define WORDS_TO_BYTES(x) ((x) << JIT_LOG_WORD_SIZE) #define MAX_TRY_SHIFT 30 +#define JIT_LOG_DOUBLE_SIZE 3 + /* a mzchar is an int: */ #define LOG_MZCHAR_SIZE 2 @@ -134,15 +136,18 @@ static void *call_original_binary_rev_arith_code; static void *call_original_unary_arith_for_branch_code; static void *call_original_binary_arith_for_branch_code; static void *call_original_binary_rev_arith_for_branch_code; +static void *call_original_nary_arith_code; static void *bad_car_code, *bad_cdr_code; static void *bad_caar_code, *bad_cdar_code, *bad_cadr_code, *bad_cddr_code; static void *bad_mcar_code, *bad_mcdr_code; static void *bad_set_mcar_code, *bad_set_mcdr_code; static void *bad_unbox_code; static void *bad_vector_length_code; +static void *bad_flvector_length_code; static void *vector_ref_code, *vector_ref_check_index_code, *vector_set_code, *vector_set_check_index_code; static void *string_ref_code, *string_ref_check_index_code, *string_set_code, *string_set_check_index_code; static void *bytes_ref_code, *bytes_ref_check_index_code, *bytes_set_code, *bytes_set_check_index_code; +static void *flvector_ref_check_index_code, *flvector_set_check_index_code; static void *syntax_e_code; void *scheme_on_demand_jit_code; static void *on_demand_jit_arity_code; @@ -206,7 +211,7 @@ typedef Scheme_Object *(*Native_Get_Arity_Proc)(Scheme_Object *o, int dumm1, int static Native_Check_Arity_Proc check_arity_code; static Native_Get_Arity_Proc get_arity_code; -static int generate_non_tail(Scheme_Object *obj, mz_jit_state *jitter, int multi_ok, int need_ends); +static int generate_non_tail(Scheme_Object *obj, mz_jit_state *jitter, int multi_ok, int need_ends, int ignored); static int generate(Scheme_Object *obj, mz_jit_state *jitter, int tail_ok, int multi_ok, int target); static void *generate_lambda_simple_arity_check(int num_params, int has_rest, int is_method, int permanent); static void generate_case_lambda(Scheme_Case_Lambda *c, Scheme_Native_Closure_Data *ndata, @@ -1047,7 +1052,7 @@ static int mz_remap_it(mz_jit_state *jitter, int i) while (p && (j >= 0)) { c = jitter->mappings[p]; if (c & 0x1) { - /* native push */ + /* native push or skip */ c >>= 1; i += c; if (c < 0) @@ -2097,6 +2102,27 @@ static int is_constant_and_avoids_r1(Scheme_Object *obj) return (t >= _scheme_compiled_values_types_); } +static int is_relatively_constant_and_avoids_r1(Scheme_Object *obj, Scheme_Object *wrt) +{ + Scheme_Type t; + + if (is_constant_and_avoids_r1(obj)) + return 1; + + t = SCHEME_TYPE(obj); + if (SAME_TYPE(t, scheme_local_type)) { + /* Must have clearing or other-clears flag set */ + Scheme_Type t2 = SCHEME_TYPE(wrt); + if (t2 == scheme_local_type) { + /* If different local vars, then order doesn't matter */ + if (SCHEME_LOCAL_POS(wrt) != SCHEME_LOCAL_POS(obj)) + return 1; + } + } + + return 0; +} + /*========================================================================*/ /* application codegen */ /*========================================================================*/ @@ -3063,7 +3089,7 @@ static void register_helper_func(mz_jit_state *jitter, void *code) #endif } -int do_generate_shared_call(mz_jit_state *jitter, void *_data) +static int do_generate_shared_call(mz_jit_state *jitter, void *_data) { Generate_Call_Data *data = (Generate_Call_Data *)_data; @@ -3226,7 +3252,9 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ rator = (alt_rands ? alt_rands[0] : app->args[0]); - if (SCHEME_PRIMP(rator)) { + if (no_call == 2) { + direct_prim = 1; + } else if (SCHEME_PRIMP(rator)) { if ((num_rands >= ((Scheme_Primitive_Proc *)rator)->mina) && ((num_rands <= ((Scheme_Primitive_Proc *)rator)->mu.maxa) || (((Scheme_Primitive_Proc *)rator)->mina < 0)) @@ -3351,7 +3379,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ } if (num_rands) { - if (!direct_prim || (num_rands > 1)) { + if (!direct_prim || (num_rands > 1) || (no_call == 2)) { mz_rs_dec(num_rands); need_safety = num_rands; CHECK_RUNSTACK_OVERFLOW(); @@ -3382,7 +3410,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ need_safety = 0; } - generate_non_tail(rator, jitter, 0, !need_non_tail); /* sync'd after args below */ + generate_non_tail(rator, jitter, 0, !need_non_tail, 0); /* sync'd after args below */ CHECK_LIMIT(); if (num_rands) { @@ -3418,14 +3446,14 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ CHECK_LIMIT(); need_safety = 0; } - generate_non_tail(arg, jitter, 0, !need_non_tail); /* sync'd below */ + generate_non_tail(arg, jitter, 0, !need_non_tail, 0); /* sync'd below */ RESUME_JIT_DATA(); CHECK_LIMIT(); if ((i == num_rands - 1) && !direct_prim && !reorder_ok && !direct_self && !proc_already_in_place) { /* Move rator back to register: */ mz_rs_ldxi(JIT_V1, i + offset); } - if ((!direct_prim || (num_rands > 1)) + if ((!direct_prim || (num_rands > 1) || (no_call == 2)) && (!direct_self || !is_tail || no_call || (i + 1 < num_rands))) { mz_rs_stxi(i + offset, JIT_R0); } @@ -3571,6 +3599,8 @@ static int is_unboxable_op(Scheme_Object *obj, int flag) if (IS_NAMED_PRIM(obj, "unsafe-fl/")) return 1; if (IS_NAMED_PRIM(obj, "unsafe-flabs")) return 1; if (IS_NAMED_PRIM(obj, "unsafe-fx->fl")) return 1; + if (IS_NAMED_PRIM(obj, "unsafe-f64vector-ref")) return 1; + if (IS_NAMED_PRIM(obj, "unsafe-flvector-ref")) return 1; return 0; } @@ -3618,7 +3648,7 @@ static int can_unbox(Scheme_Object *obj, int fuel, int regs) if (!can_unbox(app->rand1, fuel - 1, regs)) return 0; return can_unbox(app->rand2, fuel - 1, regs - 1); - } + } case scheme_toplevel_type: case scheme_local_type: case scheme_local_unbox_type: @@ -3740,6 +3770,7 @@ static int can_fast_double(int arith, int cmp, int two_args) #define jit_ldi_d_fppush(rd, is) jit_ldi_d(rd, is) #define jit_ldr_d_fppush(rd, rs) jit_ldr_d(rd, rs) #define jit_ldxi_d_fppush(rd, rs, is) jit_ldxi_d(rd, rs, is) +#define jit_ldxr_d_fppush(rd, rs, is) jit_ldxr_d(rd, rs, is) #define jit_addr_d_fppop(rd,s1,s2) jit_addr_d(rd,s1,s2) #define jit_subr_d_fppop(rd,s1,s2) jit_subr_d(rd,s1,s2) #define jit_subrr_d_fppop(rd,s1,s2) jit_subrr_d(rd,s1,s2) @@ -3751,6 +3782,7 @@ static int can_fast_double(int arith, int cmp, int two_args) #define jit_sti_d_fppop(id, rs) jit_sti_d(id, rs) #define jit_str_d_fppop(id, rd, rs) jit_str_d(id, rd, rs) #define jit_stxi_d_fppop(id, rd, rs) jit_stxi_d(id, rd, rs) +#define jit_stxr_d_fppop(id, rd, rs) jit_stxr_d(id, rd, rs) #define jit_bger_d_fppop(d, s1, s2) jit_bger_d(d, s1, s2) #define jit_bantiger_d_fppop(d, s1, s2) jit_bantiger_d(d, s1, s2) #define jit_bler_d_fppop(d, s1, s2) jit_bler_d(d, s1, s2) @@ -3816,10 +3848,10 @@ static int generate_double_arith(mz_jit_state *jitter, int arith, int cmp, int r } else ref8 = NULL; jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type); - ref9 = jit_bnei_p(jit_forward(), JIT_R2, scheme_double_type); + ref9 = jit_bnei_i(jit_forward(), JIT_R2, scheme_double_type); if (two_args) { jit_ldxi_s(JIT_R2, JIT_R1, &((Scheme_Object *)0x0)->type); - ref10 = jit_bnei_p(jit_forward(), JIT_R2, scheme_double_type); + ref10 = jit_bnei_i(jit_forward(), JIT_R2, scheme_double_type); } else ref10 = NULL; CHECK_LIMIT(); @@ -3990,7 +4022,7 @@ static int generate_double_arith(mz_jit_state *jitter, int arith, int cmp, int r static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Object *rand, Scheme_Object *rand2, int orig_args, int arith, int cmp, int v, jit_insn **for_branch, int branch_short, - int unsafe_fx, int unsafe_fl) + int unsafe_fx, int unsafe_fl, GC_CAN_IGNORE jit_insn *overflow_refslow) /* needs de-sync */ /* Either arith is non-zero or it's a cmp; the value of each determines the operation: arith = 1 -> + or add1 (if !rand2) @@ -4013,7 +4045,12 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj cmp = +/-1 -> >=/<= cmp = +/-2 -> >/< or positive/negative? cmp = 3 -> bitwise-bit-test? - */ + If rand is NULL, then we're generating part of the fast path for an + nary arithmatic over a binary operator; the first argument is + already in R0 (fixnum or min/max) or a floating-point register + (flonum) and the second arguement is in R1 (fixnum or min/max) or a + floating-point register (flonum). +*/ { GC_CAN_IGNORE jit_insn *ref, *ref2, *ref3, *ref4, *refd = NULL, *refdt = NULL, *refslow; int skipped, simple_rand, simple_rand2, reversed = 0, has_fixnum_fast = 1; @@ -4021,11 +4058,16 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj LOG_IT(("inlined %s\n", ((Scheme_Primitive_Proc *)rator)->name)); if (unsafe_fl - && can_unbox(rand, 5, JIT_FPR_NUM-2) - && (!rand2 || can_unbox(rand2, 5, JIT_FPR_NUM-3))) { + && (!rand + || (can_unbox(rand, 5, JIT_FPR_NUM-2) + && (!rand2 || can_unbox(rand2, 5, JIT_FPR_NUM-3))))) { /* Unsafe, unboxed floating-point ops. */ - jitter->unbox++; - if (!rand2) { + int args_unboxed = ((arith != 9) && (arith != 10)); + if (args_unboxed) + jitter->unbox++; + if (!rand) { + CHECK_LIMIT(); + } else if (!rand2) { mz_runstack_skipped(jitter, 1); generate(rand, jitter, 0, 1, JIT_R0); CHECK_LIMIT(); @@ -4038,12 +4080,15 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj CHECK_LIMIT(); mz_runstack_unskipped(jitter, 2); } - --jitter->unbox; - jitter->unbox_depth -= (rand2 ? 2 : 1); + if (args_unboxed) { + --jitter->unbox; + jitter->unbox_depth -= (rand ? (rand2 ? 2 : 1) : 2); + } if (for_branch) mz_rs_sync(); /* needed if arguments were unboxed */ - generate_double_arith(jitter, arith, cmp, 0, !!rand2, 0, - &refd, &refdt, branch_short, 1, 1, jitter->unbox); + generate_double_arith(jitter, arith, cmp, reversed, !!rand2, 0, + &refd, &refdt, branch_short, 1, + args_unboxed, jitter->unbox); CHECK_LIMIT(); ref3 = NULL; ref = NULL; @@ -4056,261 +4101,274 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj /* While generating a fixnum op, don't unbox! */ jitter->unbox = 0; - if (rand2) { - if (SCHEME_INTP(rand2) - && SCHEME_INT_SMALL_ENOUGH(rand2) - && ((arith != 6) - || ((SCHEME_INT_VAL(rand2) <= MAX_TRY_SHIFT) - && (SCHEME_INT_VAL(rand2) >= -MAX_TRY_SHIFT))) - && ((cmp != 3) - || ((SCHEME_INT_VAL(rand2) <= MAX_TRY_SHIFT) - && (SCHEME_INT_VAL(rand2) >= 0)))) { - /* Second is constant, so use constant mode. - For arithmetic shift, only do this if the constant - is in range. */ - v = SCHEME_INT_VAL(rand2); - rand2 = NULL; - } else if (SCHEME_INTP(rand) - && SCHEME_INT_SMALL_ENOUGH(rand) - && (arith != 6) && (arith != -6) - && (cmp != 3)) { - /* First is constant; swap argument order and use constant mode. */ - v = SCHEME_INT_VAL(rand); - cmp = -cmp; - rand = rand2; - rand2 = NULL; - reversed = 1; - } else if ((ok_to_move_local(rand2) - || SCHEME_INTP(rand2)) - && !(ok_to_move_local(rand) - || SCHEME_INTP(rand))) { - /* Second expression is side-effect-free, unlike the first; - swap order and use the fast path for when the first arg is - side-effect free. */ - Scheme_Object *t = rand2; - rand2 = rand; - rand = t; - cmp = -cmp; - reversed = 1; - } - } - - if ((arith == -1) && (orig_args == 1) && !v) { - /* Unary subtract */ + if (!rand) { + /* generating for an nary operation; first arg in R0, + second in R1 */ reversed = 1; - } - - if (rand2) { - simple_rand = (ok_to_move_local(rand) - || SCHEME_INTP(rand)); - if (!simple_rand) - simple_rand2 = SAME_TYPE(SCHEME_TYPE(rand2), scheme_local_type); - else - simple_rand2 = 0; + cmp = -cmp; + refslow = overflow_refslow; + refd = NULL; + refdt = NULL; + ref3 = NULL; + ref = NULL; + ref4 = NULL; } else { - simple_rand = 0; - simple_rand2 = 0; - } + if (rand2) { + if (SCHEME_INTP(rand2) + && SCHEME_INT_SMALL_ENOUGH(rand2) + && ((arith != 6) + || ((SCHEME_INT_VAL(rand2) <= MAX_TRY_SHIFT) + && (SCHEME_INT_VAL(rand2) >= -MAX_TRY_SHIFT))) + && ((cmp != 3) + || ((SCHEME_INT_VAL(rand2) <= MAX_TRY_SHIFT) + && (SCHEME_INT_VAL(rand2) >= 0)))) { + /* Second is constant, so use constant mode. + For arithmetic shift, only do this if the constant + is in range. */ + v = SCHEME_INT_VAL(rand2); + rand2 = NULL; + } else if (SCHEME_INTP(rand) + && SCHEME_INT_SMALL_ENOUGH(rand) + && (arith != 6) && (arith != -6) + && (cmp != 3)) { + /* First is constant; swap argument order and use constant mode. */ + v = SCHEME_INT_VAL(rand); + cmp = -cmp; + rand = rand2; + rand2 = NULL; + reversed = 1; + } else if ((ok_to_move_local(rand2) + || SCHEME_INTP(rand2)) + && !(ok_to_move_local(rand) + || SCHEME_INTP(rand))) { + /* Second expression is side-effect-free, unlike the first; + swap order and use the fast path for when the first arg is + side-effect free. */ + Scheme_Object *t = rand2; + rand2 = rand; + rand = t; + cmp = -cmp; + reversed = 1; + } + } - if (rand2 && !simple_rand && !simple_rand2) - skipped = orig_args - 1; - else - skipped = orig_args; + if ((arith == -1) && (orig_args == 1) && !v) { + /* Unary subtract */ + reversed = 1; + } + + if (rand2) { + simple_rand = (ok_to_move_local(rand) + || SCHEME_INTP(rand)); + if (!simple_rand) + simple_rand2 = SAME_TYPE(SCHEME_TYPE(rand2), scheme_local_type); + else + simple_rand2 = 0; + } else { + simple_rand = 0; + simple_rand2 = 0; + } - mz_runstack_skipped(jitter, skipped); + if (rand2 && !simple_rand && !simple_rand2) + skipped = orig_args - 1; + else + skipped = orig_args; - if (rand2 && !simple_rand && !simple_rand2) { - mz_runstack_skipped(jitter, 1); - generate_non_tail(rand, jitter, 0, 1); /* sync'd later */ - CHECK_LIMIT(); - mz_runstack_unskipped(jitter, 1); - mz_rs_dec(1); - CHECK_RUNSTACK_OVERFLOW(); - mz_runstack_pushed(jitter, 1); - mz_rs_str(JIT_R0); - } - /* not sync'd... */ + mz_runstack_skipped(jitter, skipped); - if (simple_rand2) { - if (SAME_TYPE(SCHEME_TYPE(rand), scheme_local_type)) - generate(rand, jitter, 0, 0, JIT_R1); /* sync'd below */ - else { - generate_non_tail(rand, jitter, 0, 1); /* sync'd below */ + if (rand2 && !simple_rand && !simple_rand2) { + mz_runstack_skipped(jitter, 1); + generate_non_tail(rand, jitter, 0, 1, 0); /* sync'd later */ CHECK_LIMIT(); - jit_movr_p(JIT_R1, JIT_R0); + mz_runstack_unskipped(jitter, 1); + mz_rs_dec(1); + CHECK_RUNSTACK_OVERFLOW(); + mz_runstack_pushed(jitter, 1); + mz_rs_str(JIT_R0); + } + /* not sync'd... */ + + if (simple_rand2) { + if (SAME_TYPE(SCHEME_TYPE(rand), scheme_local_type)) + generate(rand, jitter, 0, 0, JIT_R1); /* sync'd below */ + else { + generate_non_tail(rand, jitter, 0, 1, 0); /* sync'd below */ + CHECK_LIMIT(); + jit_movr_p(JIT_R1, JIT_R0); + } + CHECK_LIMIT(); + generate(rand2, jitter, 0, 0, JIT_R0); /* sync'd below */ + } else { + generate_non_tail(rand2 ? rand2 : rand, jitter, 0, 1, 0); /* sync'd below */ } CHECK_LIMIT(); - generate(rand2, jitter, 0, 0, JIT_R0); /* sync'd below */ - } else { - generate_non_tail(rand2 ? rand2 : rand, jitter, 0, 1); /* sync'd below */ - } - CHECK_LIMIT(); - /* sync'd in three branches below */ + /* sync'd in three branches below */ - if (arith == -2) { - if (rand2 || (v != 1) || reversed) - has_fixnum_fast = 0; - } + if (arith == -2) { + if (rand2 || (v != 1) || reversed) + has_fixnum_fast = 0; + } - /* rand2 in R0, and rand in R1 unless it's simple */ + /* rand2 in R0, and rand in R1 unless it's simple */ - if (simple_rand || simple_rand2) { - int pos, va; + if (simple_rand || simple_rand2) { + int pos, va; - if (simple_rand && SCHEME_INTP(rand)) { - (void)jit_movi_p(JIT_R1, rand); - va = JIT_R0; - } else { - if (simple_rand) { - pos = mz_remap(SCHEME_LOCAL_POS(rand)); - mz_rs_ldxi(JIT_R1, pos); + if (simple_rand && SCHEME_INTP(rand)) { + (void)jit_movi_p(JIT_R1, rand); + va = JIT_R0; + } else { + if (simple_rand) { + pos = mz_remap(SCHEME_LOCAL_POS(rand)); + mz_rs_ldxi(JIT_R1, pos); + } + if (!unsafe_fx && !unsafe_fl) { + /* check both fixnum bits at once by ANDing into R2: */ + jit_andr_ul(JIT_R2, JIT_R0, JIT_R1); + va = JIT_R2; + } } + if (!unsafe_fx && !unsafe_fl) { + mz_rs_sync(); + + __START_TINY_JUMPS__(1); + ref2 = jit_bmsi_ul(jit_forward(), va, 0x1); + __END_TINY_JUMPS__(1); + } else { + ref2 = NULL; + if (for_branch) mz_rs_sync(); + } + + if (unsafe_fl || (!unsafe_fx && !SCHEME_INTP(rand) && can_fast_double(arith, cmp, 1))) { + /* Maybe they're both doubles... */ + if (unsafe_fl) mz_rs_sync(); + generate_double_arith(jitter, arith, cmp, reversed, 1, 0, &refd, &refdt, branch_short, unsafe_fl, 0, 0); + CHECK_LIMIT(); + } + + if (!unsafe_fx && !unsafe_fl) { + if (!has_fixnum_fast) { + __START_TINY_JUMPS__(1); + mz_patch_branch(ref2); + __END_TINY_JUMPS__(1); + } + + /* Slow path */ + refslow = generate_arith_slow_path(jitter, rator, &ref, &ref4, for_branch, orig_args, reversed, arith, 0, 0); + + if (has_fixnum_fast) { + __START_TINY_JUMPS__(1); + mz_patch_branch(ref2); + __END_TINY_JUMPS__(1); + } + } else { + refslow = overflow_refslow; + ref = NULL; + ref4 = NULL; + } + CHECK_LIMIT(); + } else if (rand2) { + /* Move rand result back into R1 */ + mz_rs_ldr(JIT_R1); + mz_rs_inc(1); + mz_runstack_popped(jitter, 1); + + if (!unsafe_fx && !unsafe_fl) { + mz_rs_sync(); + /* check both fixnum bits at once by ANDing into R2: */ jit_andr_ul(JIT_R2, JIT_R0, JIT_R1); - va = JIT_R2; - } - } - - if (!unsafe_fx && !unsafe_fl) { - mz_rs_sync(); - - __START_TINY_JUMPS__(1); - ref2 = jit_bmsi_ul(jit_forward(), va, 0x1); - __END_TINY_JUMPS__(1); - } else { - ref2 = NULL; - if (for_branch) mz_rs_sync(); - } - - if (unsafe_fl || (!unsafe_fx && !SCHEME_INTP(rand) && can_fast_double(arith, cmp, 1))) { - /* Maybe they're both doubles... */ - if (unsafe_fl) mz_rs_sync(); - generate_double_arith(jitter, arith, cmp, reversed, 1, 0, &refd, &refdt, branch_short, unsafe_fl, 0, 0); - CHECK_LIMIT(); - } - - if (!unsafe_fx && !unsafe_fl) { - if (!has_fixnum_fast) { __START_TINY_JUMPS__(1); - mz_patch_branch(ref2); + ref2 = jit_bmsi_ul(jit_forward(), JIT_R2, 0x1); __END_TINY_JUMPS__(1); + CHECK_LIMIT(); + } else { + if (for_branch) mz_rs_sync(); + ref2 = NULL; + CHECK_LIMIT(); } - /* Slow path */ - refslow = generate_arith_slow_path(jitter, rator, &ref, &ref4, for_branch, orig_args, reversed, arith, 0, 0); - - if (has_fixnum_fast) { - __START_TINY_JUMPS__(1); - mz_patch_branch(ref2); - __END_TINY_JUMPS__(1); - } - } else { - refslow = NULL; - ref = NULL; - ref4 = NULL; - } - CHECK_LIMIT(); - } else if (rand2) { - /* Move rand result back into R1 */ - mz_rs_ldr(JIT_R1); - mz_rs_inc(1); - mz_runstack_popped(jitter, 1); - - if (!unsafe_fx && !unsafe_fl) { - mz_rs_sync(); - - /* check both fixnum bits at once by ANDing into R2: */ - jit_andr_ul(JIT_R2, JIT_R0, JIT_R1); - __START_TINY_JUMPS__(1); - ref2 = jit_bmsi_ul(jit_forward(), JIT_R2, 0x1); - __END_TINY_JUMPS__(1); - CHECK_LIMIT(); - } else { - if (for_branch) mz_rs_sync(); - ref2 = NULL; - CHECK_LIMIT(); - } - - if (unsafe_fl || (!unsafe_fx && can_fast_double(arith, cmp, 1))) { - /* Maybe they're both doubles... */ - if (unsafe_fl) mz_rs_sync(); - generate_double_arith(jitter, arith, cmp, reversed, 1, 0, &refd, &refdt, branch_short, unsafe_fl, 0, 0); - CHECK_LIMIT(); - } - - if (!unsafe_fx && !unsafe_fl) { - if (!has_fixnum_fast) { - __START_TINY_JUMPS__(1); - mz_patch_branch(ref2); - __END_TINY_JUMPS__(1); + if (unsafe_fl || (!unsafe_fx && can_fast_double(arith, cmp, 1))) { + /* Maybe they're both doubles... */ + if (unsafe_fl) mz_rs_sync(); + generate_double_arith(jitter, arith, cmp, reversed, 1, 0, &refd, &refdt, branch_short, unsafe_fl, 0, 0); + CHECK_LIMIT(); } - /* Slow path */ - refslow = generate_arith_slow_path(jitter, rator, &ref, &ref4, for_branch, orig_args, reversed, arith, 0, 0); + if (!unsafe_fx && !unsafe_fl) { + if (!has_fixnum_fast) { + __START_TINY_JUMPS__(1); + mz_patch_branch(ref2); + __END_TINY_JUMPS__(1); + } + + /* Slow path */ + refslow = generate_arith_slow_path(jitter, rator, &ref, &ref4, for_branch, orig_args, reversed, arith, 0, 0); - if (has_fixnum_fast) { - /* Fixnum branch: */ - __START_TINY_JUMPS__(1); - mz_patch_branch(ref2); - __END_TINY_JUMPS__(1); - } - CHECK_LIMIT(); - } else { - refslow = NULL; - ref = NULL; - ref4 = NULL; - } - } else { - /* Only one argument: */ - if (!unsafe_fx && !unsafe_fl) { - mz_rs_sync(); - __START_TINY_JUMPS__(1); - ref2 = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1); - __END_TINY_JUMPS__(1); - } else { - if (for_branch) mz_rs_sync(); - ref2 = NULL; - } - - if (unsafe_fl - || ((orig_args != 2) /* <- heuristic: we could generate code when an exact argument is - given, but the extra FP code is probably not worthwhile. */ - && !unsafe_fx - && can_fast_double(arith, cmp, 0) - /* watch out: divide by 0 is special: */ - && ((arith != -2) || v || reversed))) { - /* Maybe it's a double... */ - generate_double_arith(jitter, arith, cmp, reversed, 0, v, &refd, &refdt, branch_short, unsafe_fl, 0, 0); - CHECK_LIMIT(); - } - - if (!unsafe_fx && !unsafe_fl) { - if (!has_fixnum_fast) { - __START_TINY_JUMPS__(1); - mz_patch_branch(ref2); - __END_TINY_JUMPS__(1); - } - - /* Slow path */ - refslow = generate_arith_slow_path(jitter, rator, &ref, &ref4, for_branch, orig_args, reversed, arith, 1, v); - - if (has_fixnum_fast) { - __START_TINY_JUMPS__(1); - mz_patch_branch(ref2); - __END_TINY_JUMPS__(1); + if (has_fixnum_fast) { + /* Fixnum branch: */ + __START_TINY_JUMPS__(1); + mz_patch_branch(ref2); + __END_TINY_JUMPS__(1); + } + CHECK_LIMIT(); + } else { + refslow = overflow_refslow; + ref = NULL; + ref4 = NULL; } } else { - refslow = NULL; - ref = NULL; - ref4 = NULL; + /* Only one argument: */ + if (!unsafe_fx && !unsafe_fl) { + mz_rs_sync(); + __START_TINY_JUMPS__(1); + ref2 = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1); + __END_TINY_JUMPS__(1); + } else { + if (for_branch) mz_rs_sync(); + ref2 = NULL; + } + + if (unsafe_fl + || ((orig_args != 2) /* <- heuristic: we could generate code when an exact argument is + given, but the extra FP code is probably not worthwhile. */ + && !unsafe_fx + && can_fast_double(arith, cmp, 0) + /* watch out: divide by 0 is special: */ + && ((arith != -2) || v || reversed))) { + /* Maybe it's a double... */ + generate_double_arith(jitter, arith, cmp, reversed, 0, v, &refd, &refdt, branch_short, unsafe_fl, 0, 0); + CHECK_LIMIT(); + } + + if (!unsafe_fx && !unsafe_fl) { + if (!has_fixnum_fast) { + __START_TINY_JUMPS__(1); + mz_patch_branch(ref2); + __END_TINY_JUMPS__(1); + } + + /* Slow path */ + refslow = generate_arith_slow_path(jitter, rator, &ref, &ref4, for_branch, orig_args, reversed, arith, 1, v); + + if (has_fixnum_fast) { + __START_TINY_JUMPS__(1); + mz_patch_branch(ref2); + __END_TINY_JUMPS__(1); + } + } else { + refslow = overflow_refslow; + ref = NULL; + ref4 = NULL; + } } + + CHECK_LIMIT(); + + mz_runstack_unskipped(jitter, skipped); } - CHECK_LIMIT(); - - mz_runstack_unskipped(jitter, skipped); - __START_SHORT_JUMPS__(branch_short); if (!unsafe_fl) { @@ -4325,21 +4383,22 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj /* First arg is in JIT_R1, second is in JIT_R0 */ if (arith == 1) { jit_andi_ul(JIT_R2, JIT_R1, (~0x1)); - if (unsafe_fx) - jit_addr_l(JIT_R2, JIT_R2, JIT_R0); - else + if (unsafe_fx && !overflow_refslow) + jit_addr_l(JIT_R0, JIT_R2, JIT_R0); + else { (void)jit_boaddr_l(refslow, JIT_R2, JIT_R0); - jit_movr_p(JIT_R0, JIT_R2); + jit_movr_p(JIT_R0, JIT_R2); + } } else if (arith == -1) { if (reversed) { jit_movr_p(JIT_R2, JIT_R0); - if (unsafe_fx) + if (unsafe_fx && !overflow_refslow) jit_subr_l(JIT_R2, JIT_R2, JIT_R1); else (void)jit_bosubr_l(refslow, JIT_R2, JIT_R1); } else { jit_movr_p(JIT_R2, JIT_R1); - if (unsafe_fx) + if (unsafe_fx && !overflow_refslow) (void)jit_subr_l(JIT_R2, JIT_R2, JIT_R0); else (void)jit_bosubr_l(refslow, JIT_R2, JIT_R0); @@ -4348,7 +4407,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj } else if (arith == 2) { jit_andi_ul(JIT_R2, JIT_R1, (~0x1)); jit_rshi_l(JIT_V1, JIT_R0, 0x1); - if (unsafe_fx) + if (unsafe_fx && !overflow_refslow) jit_mulr_l(JIT_V1, JIT_V1, JIT_R2); else (void)jit_bomulr_l(refslow, JIT_V1, JIT_R2); @@ -4363,14 +4422,14 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj jit_rshi_l(JIT_V1, JIT_R0, 0x1); jit_rshi_l(JIT_R2, JIT_R1, 0x1); if (reversed) { - if (!unsafe_fx) + if (!unsafe_fx || overflow_refslow) (void)jit_beqi_l(refslow, JIT_R2, 0); if (arith == -3) jit_divr_l(JIT_R0, JIT_V1, JIT_R2); else jit_modr_l(JIT_R0, JIT_V1, JIT_R2); } else { - if (!unsafe_fx) + if (!unsafe_fx || overflow_refslow) (void)jit_beqi_l(refslow, JIT_V1, 0); if (arith == -3) jit_divr_l(JIT_R0, JIT_R2, JIT_V1); @@ -4397,14 +4456,14 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj int v2 = (reversed ? JIT_R1 : JIT_R0); jit_insn *refi, *refc; - if (!unsafe_fx) + if (!unsafe_fx || overflow_refslow) refi = jit_bgei_l(jit_forward(), v2, (long)scheme_make_integer(0)); else refi = NULL; - if (!unsafe_fx || (arith == -6)) { + if (!unsafe_fx || overflow_refslow || (arith == -6)) { /* Right shift */ - if (!unsafe_fx) { + if (!unsafe_fx || overflow_refslow) { /* check for a small enough shift */ (void)jit_blti_l(refslow, v2, scheme_make_integer(-MAX_TRY_SHIFT)); jit_notr_l(JIT_V1, v2); @@ -4412,7 +4471,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj } else { jit_rshi_l(JIT_V1, v2, 0x1); } - if (!unsafe_fx) + if (!unsafe_fx || overflow_refslow) jit_addi_l(JIT_V1, JIT_V1, 0x1); CHECK_LIMIT(); #ifdef MZ_USE_JIT_I386 @@ -4423,7 +4482,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj jit_rshr_l(JIT_R2, v1, JIT_V1); #endif jit_ori_l(JIT_R0, JIT_R2, 0x1); - if (!unsafe_fx) + if (!unsafe_fx || overflow_refslow) refc = jit_jmpi(jit_forward()); else refc = NULL; @@ -4432,10 +4491,10 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj refc = NULL; /* Left shift */ - if (!unsafe_fx || (arith == 6)) { + if (!unsafe_fx || overflow_refslow || (arith == 6)) { if (refi) mz_patch_branch(refi); - if (!unsafe_fx) + if (!unsafe_fx || overflow_refslow) (void)jit_bgti_l(refslow, v2, (long)scheme_make_integer(MAX_TRY_SHIFT)); jit_rshi_l(JIT_V1, v2, 0x1); jit_andi_l(v1, v1, (~0x1)); @@ -4449,8 +4508,8 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj CHECK_LIMIT(); /* If shifting back right produces a different result, that's overflow... */ jit_rshr_l(JIT_V1, JIT_R2, JIT_V1); - /* !! In case we go refslow, it nseed to add back tag to v1 !! */ - if (!unsafe_fx) + /* !! In case we go refslow, it needs to add back tag to v1 !! */ + if (!unsafe_fx || overflow_refslow) (void)jit_bner_p(refslow, JIT_V1, v1); /* No overflow. */ jit_ori_l(JIT_R0, JIT_R2, 0x1); @@ -4478,27 +4537,29 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj } else { /* Non-constant arg is in JIT_R0 */ if (arith == 1) { - jit_movr_p(JIT_R2, JIT_R0); - if (unsafe_fx) - jit_addi_l(JIT_R2, JIT_R2, v << 1); - else + if (unsafe_fx && !overflow_refslow) + jit_addi_l(JIT_R0, JIT_R0, v << 1); + else { + jit_movr_p(JIT_R2, JIT_R0); (void)jit_boaddi_l(refslow, JIT_R2, v << 1); - jit_movr_p(JIT_R0, JIT_R2); + jit_movr_p(JIT_R0, JIT_R2); + } } else if (arith == -1) { if (reversed) { (void)jit_movi_p(JIT_R2, scheme_make_integer(v)); - if (unsafe_fx) + if (unsafe_fx && !overflow_refslow) jit_subr_l(JIT_R2, JIT_R2, JIT_R0); else (void)jit_bosubr_l(refslow, JIT_R2, JIT_R0); jit_addi_ul(JIT_R0, JIT_R2, 0x1); } else { - jit_movr_p(JIT_R2, JIT_R0); - if (unsafe_fx) - jit_subi_l(JIT_R2, JIT_R2, v << 1); - else + if (unsafe_fx && !overflow_refslow) + jit_subi_l(JIT_R0, JIT_R0, v << 1); + else { + jit_movr_p(JIT_R2, JIT_R0); (void)jit_bosubi_l(refslow, JIT_R2, v << 1); - jit_movr_p(JIT_R0, JIT_R2); + jit_movr_p(JIT_R0, JIT_R2); + } } } else if (arith == 2) { if (v == 1) { @@ -4509,7 +4570,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj (void)jit_movi_p(JIT_R1, scheme_make_integer(v)); jit_andi_ul(JIT_R2, JIT_R1, (~0x1)); jit_rshi_l(JIT_V1, JIT_R0, 0x1); - if (unsafe_fx) + if (unsafe_fx && !overflow_refslow) jit_mulr_l(JIT_V1, JIT_V1, JIT_R2); else (void)jit_bomulr_l(refslow, JIT_V1, JIT_R2); @@ -4549,7 +4610,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj } else { jit_andi_l(JIT_R0, JIT_R0, (~0x1)); jit_lshi_l(JIT_R2, JIT_R0, v); - if (!unsafe_fx) { + if (!unsafe_fx && !overflow_refslow) { /* If shifting back right produces a different result, that's overflow... */ jit_rshi_l(JIT_V1, JIT_R2, v); /* !! In case we go refslow, it nseed to add back tag to JIT_R0 !! */ @@ -4584,7 +4645,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj refc = jit_bgei_l(jit_forward(), JIT_R0, (long)scheme_make_integer(0)); __END_INNER_TINY__(branch_short); /* watch out for most negative fixnum! */ - if (!unsafe_fx) + if (!unsafe_fx || overflow_refslow) (void)jit_beqi_p(refslow, JIT_R0, (void *)(((long)1 << ((8 * JIT_WORD_SIZE) - 1)) | 0x1)); (void)jit_movi_p(JIT_R1, scheme_make_integer(0)); jit_subr_l(JIT_R0, JIT_R1, JIT_R0); @@ -4624,7 +4685,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj switch (cmp) { case -3: if (rand2) { - if (!unsafe_fx) { + if (!unsafe_fx || overflow_refslow) { (void)jit_blti_l(refslow, JIT_R1, 0); (void)jit_bgti_l(refslow, JIT_R1, (long)scheme_make_integer(MAX_TRY_SHIFT)); } @@ -4677,7 +4738,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj default: case 3: if (rand2) { - if (!unsafe_fx) { + if (!unsafe_fx || overflow_refslow) { (void)jit_blti_l(refslow, JIT_R0, 0); (void)jit_bgti_l(refslow, JIT_R0, (long)scheme_make_integer(MAX_TRY_SHIFT)); } @@ -4728,6 +4789,271 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj return 1; } +#define MAX_NON_SIMPLE_ARGS 5 + +static int extract_nary_arg(int reg, int n, mz_jit_state *jitter, Scheme_App_Rec *app, + Scheme_Object **alt_args, int old_short_jumps) +{ + if (!alt_args) { + jit_ldxi_p(reg, JIT_RUNSTACK, WORDS_TO_BYTES(n)); + if (jitter->unbox) + generate_unboxing(jitter); + } else if (is_constant_and_avoids_r1(app->args[n+1])) { + __END_SHORT_JUMPS__(old_short_jumps); + generate(app->args[n+1], jitter, 0, 0, reg); + CHECK_LIMIT(); + __START_SHORT_JUMPS__(old_short_jumps); + } else { + int i, j = 0; + for (i = 0; i < n; i++) { + if (!is_constant_and_avoids_r1(app->args[i+1])) + j++; + } + jit_ldxi_p(reg, JIT_RUNSTACK, WORDS_TO_BYTES(j)); + if (jitter->unbox) + generate_unboxing(jitter); + } + CHECK_LIMIT(); + return 1; +} + +static void patch_nary_branches(mz_jit_state *jitter, jit_insn **refs, GC_CAN_IGNORE jit_insn *reffalse) +{ + if (refs[0]) { + mz_patch_branch_at(refs[0], reffalse); + } + if (refs[1]) { + mz_patch_branch_at(refs[1], reffalse); + } + if (refs[2]) { + jit_patch_movi(refs[2], reffalse); + } +} + +static int generate_nary_arith(mz_jit_state *jitter, Scheme_App_Rec *app, + int arith, int cmp, jit_insn **for_branch, int branch_short) +{ + int c, i, non_simple_c = 0, stack_c, use_fl = 1, use_fx = 1, trigger_arg = 0; + Scheme_Object *non_simples[1+MAX_NON_SIMPLE_ARGS], **alt_args, *v; + GC_CAN_IGNORE jit_insn *refslow, *reffx, *refdone; + GC_CAN_IGNORE jit_insn *refs[3], *reffalse = NULL, *refdone3 = NULL; +#ifdef INLINE_FP_OPS + int args_unboxed; + GC_CAN_IGNORE jit_insn *reffl, *refdone2; +#endif + + if (arith == -2) { + /* can't inline fixnum '/' */ + use_fx = 0; + } else if ((arith == 3) + || (arith == 4) + || (arith == 5)) { + /* bitwise operators are fixnum, only */ + use_fl = 0; + } + + c = app->num_args; + for (i = 0; i < c; i++) { + v = app->args[i+1]; + if (!is_constant_and_avoids_r1(v)) { + if (non_simple_c < MAX_NON_SIMPLE_ARGS) + non_simples[1+non_simple_c] = v; + non_simple_c++; + } + if (SCHEME_INTP(v)) { + use_fl = 0; + if (trigger_arg == i) + trigger_arg++; + } else if (SCHEME_FLOATP(v)) { + use_fx = 0; + if (trigger_arg == i) + trigger_arg++; + } else if (SCHEME_TYPE(v) >= _scheme_compiled_values_types_) { + use_fx = 0; + use_fl = 0; + } + } + + if ((non_simple_c <= MAX_NON_SIMPLE_ARGS) && (non_simple_c < c)) { + stack_c = non_simple_c; + alt_args = non_simples; + non_simples[0] = app->args[0]; + mz_runstack_skipped(jitter, c - stack_c); + } else { + stack_c = c; + alt_args = NULL; + } + + if (stack_c) + generate_app(app, alt_args, stack_c, jitter, 0, 0, 2); + CHECK_LIMIT(); + mz_rs_sync(); + + __START_SHORT_JUMPS__(c < 100); + + if (trigger_arg > c) { + /* we don't expect this to happen, since constant-folding would + have collapsed it */ + trigger_arg = 0; + } + + extract_nary_arg(JIT_R0, trigger_arg, jitter, app, alt_args, c < 100); + CHECK_LIMIT(); + /* trigger argument a fixnum? */ + reffx = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1); + +#ifdef INLINE_FP_OPS + if (use_fl) { + /* First argument a flonum? */ + jit_ldxi_s(JIT_R0, JIT_R0, &((Scheme_Object *)0x0)->type); + reffl = jit_beqi_i(jit_forward(), JIT_R0, scheme_double_type); + CHECK_LIMIT(); + } else { + reffl = NULL; + } +#endif + + if (!use_fx) { + mz_patch_branch(reffx); + } + + refslow = _jit.x.pc; + /* slow path */ + if (alt_args) { + /* get all args on runstack */ + int delta = stack_c - c; + for (i = 0; i < c; i++) { + if (delta) { + extract_nary_arg(JIT_R0, i, jitter, app, alt_args, c < 100); + CHECK_LIMIT(); + jit_stxi_p(WORDS_TO_BYTES(i+delta), JIT_RUNSTACK, JIT_R0); + } else + break; + } + jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(c - stack_c)); + } + (void)jit_movi_p(JIT_V1, ((Scheme_Primitive_Proc *)app->args[0])->prim_val); + (void)jit_movi_i(JIT_R1, c); + (void)jit_calli(call_original_nary_arith_code); + if (alt_args) { + jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(c - stack_c)); + } + refdone = jit_jmpi(jit_forward()); + if (!arith) { + reffalse = _jit.x.pc; + (void)jit_movi_p(JIT_R0, scheme_false); + refdone3 = jit_jmpi(jit_forward()); + } else { + reffalse = NULL; + } + +#ifdef INLINE_FP_OPS + if (use_fl) { + /* Flonum branch: */ + mz_patch_branch(reffl); + for (i = 0; i < c; i++) { + if (i != trigger_arg) { + v = app->args[i+1]; + if (!SCHEME_FLOATP(v)) { + extract_nary_arg(JIT_R0, i, jitter, app, alt_args, c < 100); + (void)jit_bmsi_ul(refslow, JIT_R0, 0x1); + jit_ldxi_s(JIT_R0, JIT_R0, &((Scheme_Object *)0x0)->type); + (void)jit_bnei_i(refslow, JIT_R0, scheme_double_type); + CHECK_LIMIT(); + } + } + } + /* All flonums, so inline fast flonum combination */ + args_unboxed = ((arith != 9) && (arith != 10)); /* no unboxing for min & max */ + if (args_unboxed) + jitter->unbox++; + extract_nary_arg(JIT_R0, 0, jitter, app, alt_args, c < 100); + CHECK_LIMIT(); + for (i = 1; i < c; i++) { + if (!arith && (i > 1)) + extract_nary_arg(JIT_R0, i - 1, jitter, app, alt_args, c < 100); + extract_nary_arg((args_unboxed ? JIT_R0 : JIT_R1), i, jitter, app, alt_args, c < 100); + if ((i == c - 1) && args_unboxed) --jitter->unbox; /* box last result */ + if (!arith) memset(refs, 0, sizeof(refs)); + __END_SHORT_JUMPS__(c < 100); + generate_arith(jitter, NULL, NULL, scheme_void, 2, arith, cmp, 0, + !arith ? refs : NULL, c < 100, 0, 1, NULL); + __START_SHORT_JUMPS__(c < 100); + if (!arith) patch_nary_branches(jitter, refs, reffalse); + CHECK_LIMIT(); + } + if (use_fx) { + refdone2 = jit_jmpi(jit_forward()); + } else { + refdone2 = NULL; + } + } else { + refdone2 = NULL; + } +#endif + + if (use_fx) { + /* Fixnum branch */ + mz_patch_branch(reffx); + for (i = 0; i < c; i++) { + if (i != trigger_arg) { + v = app->args[i+1]; + if (!SCHEME_INTP(v)) { + extract_nary_arg(JIT_R0, i, jitter, app, alt_args, c < 100); + CHECK_LIMIT(); + (void)jit_bmci_ul(refslow, JIT_R0, 0x1); + CHECK_LIMIT(); + } + } + } + /* All fixnums, so inline fast fixnum combination; + on overflow, bail out to refslow. */ + extract_nary_arg(JIT_R0, 0, jitter, app, alt_args, c < 100); + for (i = 1; i < c; i++) { + if (!arith && (i > 1)) + extract_nary_arg(JIT_R0, i - 1, jitter, app, alt_args, c < 100); + extract_nary_arg(JIT_R1, i, jitter, app, alt_args, c < 100); + CHECK_LIMIT(); + if (!arith) memset(refs, 0, sizeof(refs)); + __END_SHORT_JUMPS__(c < 100); + generate_arith(jitter, NULL, NULL, scheme_void, 2, arith, cmp, 0, + !arith ? refs : NULL, c < 100, 1, 0, refslow); + __START_SHORT_JUMPS__(c < 100); + if (!arith) patch_nary_branches(jitter, refs, reffalse); + CHECK_LIMIT(); + } + } + +#ifdef INLINE_FP_OPS + if (use_fl && use_fx) { + mz_patch_ucbranch(refdone2); + } +#endif + if (!arith) { + (void)jit_movi_p(JIT_R0, scheme_true); + } + mz_patch_ucbranch(refdone); + if (refdone3) + mz_patch_ucbranch(refdone3); + + __END_SHORT_JUMPS__(c < 100); + + if (stack_c) { + mz_rs_inc(stack_c); /* no sync */ + mz_runstack_popped(jitter, stack_c); + } + if (c > stack_c) + mz_runstack_unskipped(jitter, c - stack_c); + + if (!arith && for_branch) { + __START_SHORT_JUMPS__(branch_short); + for_branch[0] = jit_beqi_p(jit_forward(), JIT_R0, scheme_false); + __END_SHORT_JUMPS__(branch_short); + } + + return 1; +} + static int generate_inlined_constant_test(mz_jit_state *jitter, Scheme_App2_Rec *app, Scheme_Object *cnst, Scheme_Object *cnst2, jit_insn **for_branch, int branch_short, int need_sync) @@ -4739,7 +5065,7 @@ static int generate_inlined_constant_test(mz_jit_state *jitter, Scheme_App2_Rec mz_runstack_skipped(jitter, 1); - generate_non_tail(app->rand, jitter, 0, 1); + generate_non_tail(app->rand, jitter, 0, 1, 0); CHECK_LIMIT(); mz_runstack_unskipped(jitter, 1); @@ -4784,7 +5110,7 @@ static int generate_inlined_type_test(mz_jit_state *jitter, Scheme_App2_Rec *app mz_runstack_skipped(jitter, 1); - generate_non_tail(app->rand, jitter, 0, 1); + generate_non_tail(app->rand, jitter, 0, 1, 0); CHECK_LIMIT(); mz_runstack_unskipped(jitter, 1); @@ -4978,13 +5304,13 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in generate_inlined_constant_test(jitter, app, scheme_eof, NULL, for_branch, branch_short, need_sync); return 1; } else if (IS_NAMED_PRIM(rator, "zero?")) { - generate_arith(jitter, rator, app->rand, NULL, 1, 0, 0, 0, for_branch, branch_short, 0, 0); + generate_arith(jitter, rator, app->rand, NULL, 1, 0, 0, 0, for_branch, branch_short, 0, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "negative?")) { - generate_arith(jitter, rator, app->rand, NULL, 1, 0, -2, 0, for_branch, branch_short, 0, 0); + generate_arith(jitter, rator, app->rand, NULL, 1, 0, -2, 0, for_branch, branch_short, 0, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "positive?")) { - generate_arith(jitter, rator, app->rand, NULL, 1, 0, 2, 0, for_branch, branch_short, 0, 0); + generate_arith(jitter, rator, app->rand, NULL, 1, 0, 2, 0, for_branch, branch_short, 0, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "exact-nonnegative-integer?") || IS_NAMED_PRIM(rator, "exact-positive-integer?")) { @@ -4994,7 +5320,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in mz_runstack_skipped(jitter, 1); - generate_non_tail(app->rand, jitter, 0, 1); + generate_non_tail(app->rand, jitter, 0, 1, 0); CHECK_LIMIT(); mz_runstack_unskipped(jitter, 1); @@ -5009,7 +5335,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in /* Check for positive bignum: */ __START_SHORT_JUMPS__(branch_short); jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type); - ref2 = jit_bnei_p(jit_forward(), JIT_R2, scheme_bignum_type); + ref2 = jit_bnei_i(jit_forward(), JIT_R2, scheme_bignum_type); jit_ldxi_s(JIT_R2, JIT_R0, &MZ_OPT_HASH_KEY(&((Scheme_Stx *)0x0)->iso)); ref3 = jit_bmci_ul(jit_forward(), JIT_R2, 0x1); __END_SHORT_JUMPS__(branch_short); @@ -5067,7 +5393,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in mz_runstack_skipped(jitter, 1); - generate_non_tail(app->rand, jitter, 0, 1); + generate_non_tail(app->rand, jitter, 0, 1, 0); CHECK_LIMIT(); mz_runstack_unskipped(jitter, 1); @@ -5136,7 +5462,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in mz_runstack_skipped(jitter, 1); - generate_non_tail(app->rand, jitter, 0, 1); + generate_non_tail(app->rand, jitter, 0, 1, 0); CHECK_LIMIT(); mz_runstack_unskipped(jitter, 1); @@ -5177,7 +5503,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in mz_runstack_skipped(jitter, 1); - generate_non_tail(app->rand, jitter, 0, 1); + generate_non_tail(app->rand, jitter, 0, 1, 0); CHECK_LIMIT(); mz_runstack_unskipped(jitter, 1); @@ -5191,19 +5517,32 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in return 1; } else if (IS_NAMED_PRIM(rator, "vector-length") - || IS_NAMED_PRIM(rator, "unsafe-vector-length")) { + || IS_NAMED_PRIM(rator, "unsafe-vector-length") + || IS_NAMED_PRIM(rator, "flvector-length") + || IS_NAMED_PRIM(rator, "unsafe-flvector-length")) { GC_CAN_IGNORE jit_insn *reffail, *ref; + int unsafe = 0, for_fl = 0; + + if (IS_NAMED_PRIM(rator, "unsafe-vector-length")) { + unsafe = 1; + } else if (IS_NAMED_PRIM(rator, "flvector-length")) { + for_fl = 1; + } else if (IS_NAMED_PRIM(rator, "unsafe-flvector-length")) { + unsafe = 1; + for_fl = 1; + } + LOG_IT(("inlined vector-length\n")); mz_runstack_skipped(jitter, 1); - generate_non_tail(app->rand, jitter, 0, 1); + generate_non_tail(app->rand, jitter, 0, 1, 0); CHECK_LIMIT(); mz_runstack_unskipped(jitter, 1); - if (!IS_NAMED_PRIM(rator, "unsafe-vector-length")) { + if (!unsafe) { mz_rs_sync_fail_branch(); __START_TINY_JUMPS__(1); @@ -5211,16 +5550,25 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in __END_TINY_JUMPS__(1); reffail = _jit.x.pc; - (void)jit_calli(bad_vector_length_code); + if (!for_fl) + (void)jit_calli(bad_vector_length_code); + else + (void)jit_calli(bad_flvector_length_code); __START_TINY_JUMPS__(1); mz_patch_branch(ref); jit_ldxi_s(JIT_R1, JIT_R0, &((Scheme_Object *)0x0)->type); - (void)jit_bnei_i(reffail, JIT_R1, scheme_vector_type); + if (!for_fl) + (void)jit_bnei_i(reffail, JIT_R1, scheme_vector_type); + else + (void)jit_bnei_i(reffail, JIT_R1, scheme_flvector_type); __END_TINY_JUMPS__(1); } - (void)jit_ldxi_i(JIT_R0, JIT_R0, &SCHEME_VEC_SIZE(0x0)); + if (!for_fl) + (void)jit_ldxi_i(JIT_R0, JIT_R0, &SCHEME_VEC_SIZE(0x0)); + else + (void)jit_ldxi_l(JIT_R0, JIT_R0, &SCHEME_FLVEC_SIZE(0x0)); jit_lshi_l(JIT_R0, JIT_R0, 1); jit_ori_l(JIT_R0, JIT_R0, 0x1); @@ -5231,7 +5579,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in mz_runstack_skipped(jitter, 1); - generate_non_tail(app->rand, jitter, 0, 1); + generate_non_tail(app->rand, jitter, 0, 1, 0); CHECK_LIMIT(); mz_runstack_unskipped(jitter, 1); @@ -5251,7 +5599,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in mz_runstack_skipped(jitter, 1); - generate_non_tail(app->rand, jitter, 0, 1); + generate_non_tail(app->rand, jitter, 0, 1, 0); CHECK_LIMIT(); mz_runstack_unskipped(jitter, 1); @@ -5279,7 +5627,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in mz_runstack_skipped(jitter, 1); - generate_non_tail(app->rand, jitter, 0, 1); + generate_non_tail(app->rand, jitter, 0, 1, 0); CHECK_LIMIT(); mz_runstack_unskipped(jitter, 1); @@ -5292,7 +5640,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in mz_runstack_skipped(jitter, 1); - generate_non_tail(app->rand, jitter, 0, 1); + generate_non_tail(app->rand, jitter, 0, 1, 0); CHECK_LIMIT(); mz_runstack_unskipped(jitter, 1); @@ -5303,34 +5651,34 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in return 1; } else if (IS_NAMED_PRIM(rator, "add1")) { - generate_arith(jitter, rator, app->rand, NULL, 1, 1, 0, 1, NULL, 1, 0, 0); + generate_arith(jitter, rator, app->rand, NULL, 1, 1, 0, 1, NULL, 1, 0, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "sub1")) { - generate_arith(jitter, rator, app->rand, NULL, 1, -1, 0, 1, NULL, 1, 0, 0); + generate_arith(jitter, rator, app->rand, NULL, 1, -1, 0, 1, NULL, 1, 0, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "-")) { - generate_arith(jitter, rator, app->rand, NULL, 1, -1, 0, 0, NULL, 1, 0, 0); + generate_arith(jitter, rator, app->rand, NULL, 1, -1, 0, 0, NULL, 1, 0, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "abs")) { - generate_arith(jitter, rator, app->rand, NULL, 1, 11, 0, 0, NULL, 1, 0, 0); + generate_arith(jitter, rator, app->rand, NULL, 1, 11, 0, 0, NULL, 1, 0, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "unsafe-fxabs")) { - generate_arith(jitter, rator, app->rand, NULL, 1, 11, 0, 0, NULL, 1, 1, 0); + generate_arith(jitter, rator, app->rand, NULL, 1, 11, 0, 0, NULL, 1, 1, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "unsafe-flabs")) { - generate_arith(jitter, rator, app->rand, NULL, 1, 11, 0, 0, NULL, 1, 0, 1); + generate_arith(jitter, rator, app->rand, NULL, 1, 11, 0, 0, NULL, 1, 0, 1, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "exact->inexact")) { - generate_arith(jitter, rator, app->rand, NULL, 1, 12, 0, 0, NULL, 1, 0, 0); + generate_arith(jitter, rator, app->rand, NULL, 1, 12, 0, 0, NULL, 1, 0, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "unsafe-fx->fl")) { - generate_arith(jitter, rator, app->rand, NULL, 1, 12, 0, 0, NULL, 1, 1, 0); + generate_arith(jitter, rator, app->rand, NULL, 1, 12, 0, 0, NULL, 1, 1, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "bitwise-not")) { - generate_arith(jitter, rator, app->rand, NULL, 1, 7, 0, 9, NULL, 1, 0, 0); + generate_arith(jitter, rator, app->rand, NULL, 1, 7, 0, 9, NULL, 1, 0, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "unsafe-fxnot")) { - generate_arith(jitter, rator, app->rand, NULL, 1, 7, 0, 9, NULL, 1, 1, 0); + generate_arith(jitter, rator, app->rand, NULL, 1, 7, 0, 9, NULL, 1, 1, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "vector-immutable") || IS_NAMED_PRIM(rator, "vector")) { @@ -5338,13 +5686,13 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in } else if (IS_NAMED_PRIM(rator, "list*")) { /* on a single argument, `list*' is identity */ mz_runstack_skipped(jitter, 1); - generate_non_tail(app->rand, jitter, 0, 1); + generate_non_tail(app->rand, jitter, 0, 1, 0); CHECK_LIMIT(); mz_runstack_unskipped(jitter, 1); return 1; } else if (IS_NAMED_PRIM(rator, "list")) { mz_runstack_skipped(jitter, 1); - generate_non_tail(app->rand, jitter, 0, 1); + generate_non_tail(app->rand, jitter, 0, 1, 0); CHECK_LIMIT(); mz_rs_sync(); mz_runstack_unskipped(jitter, 1); @@ -5352,7 +5700,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in return generate_cons_alloc(jitter, 0, 0); } else if (IS_NAMED_PRIM(rator, "box")) { mz_runstack_skipped(jitter, 1); - generate_non_tail(app->rand, jitter, 0, 1); + generate_non_tail(app->rand, jitter, 0, 1, 0); CHECK_LIMIT(); mz_runstack_unskipped(jitter, 1); mz_rs_sync(); @@ -5396,14 +5744,14 @@ static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_ { int simple1, simple2, direction = 1; - simple1 = is_constant_and_avoids_r1(rand1); - simple2 = is_constant_and_avoids_r1(rand2); + simple1 = is_relatively_constant_and_avoids_r1(rand1, rand2); + simple2 = is_relatively_constant_and_avoids_r1(rand2, rand1); if (!simple1) { if (simple2) { mz_runstack_skipped(jitter, skipped); - generate_non_tail(rand1, jitter, 0, 1); /* no sync... */ + generate_non_tail(rand1, jitter, 0, 1, 0); /* no sync... */ CHECK_LIMIT(); jit_movr_p(JIT_R1, JIT_R0); @@ -5421,7 +5769,7 @@ static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_ mz_runstack_unskipped(jitter, skipped); } else { mz_runstack_skipped(jitter, skipped); - generate_non_tail(rand1, jitter, 0, 1); /* no sync... */ + generate_non_tail(rand1, jitter, 0, 1, 0); /* no sync... */ CHECK_LIMIT(); mz_runstack_unskipped(jitter, skipped); @@ -5431,7 +5779,7 @@ static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_ mz_rs_str(JIT_R0); mz_runstack_skipped(jitter, skipped-1); - generate_non_tail(rand2, jitter, 0, 1); /* no sync... */ + generate_non_tail(rand2, jitter, 0, 1, 0); /* no sync... */ CHECK_LIMIT(); jit_movr_p(JIT_R1, JIT_R0); @@ -5448,7 +5796,7 @@ static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_ generate(rand2, jitter, 0, 0, JIT_R1); /* no sync... */ CHECK_LIMIT(); } else { - generate_non_tail(rand2, jitter, 0, 1); /* no sync... */ + generate_non_tail(rand2, jitter, 0, 1, 0); /* no sync... */ CHECK_LIMIT(); jit_movr_p(JIT_R1, JIT_R0); } @@ -5551,7 +5899,8 @@ static int generate_binary_char(mz_jit_state *jitter, Scheme_App3_Rec *app, return 1; } -static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready, int base_offset, int unsafe) +static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready, int base_offset, + int for_fl, int unsafe) /* if int_ready, JIT_R1 has num index (for safe mode) and JIT_V1 has pre-computed offset, otherwise JIT_R1 has fixnum index */ { @@ -5568,9 +5917,15 @@ static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready, int jit_ori_l(JIT_R1, JIT_R1, 0x1); } if (set) { - (void)jit_calli(vector_set_check_index_code); + if (!for_fl) + (void)jit_calli(vector_set_check_index_code); + else + (void)jit_calli(flvector_set_check_index_code); } else { - (void)jit_calli(vector_ref_check_index_code); + if (!for_fl) + (void)jit_calli(vector_ref_check_index_code); + else + (void)jit_calli(flvector_ref_check_index_code); } /* doesn't return */ CHECK_LIMIT(); @@ -5580,8 +5935,13 @@ static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready, int if (!int_ready) (void)jit_bmci_ul(reffail, JIT_R1, 0x1); jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type); - (void)jit_bnei_i(reffail, JIT_R2, scheme_vector_type); - jit_ldxi_i(JIT_R2, JIT_R0, (int)&SCHEME_VEC_SIZE(0x0)); + if (!for_fl) { + (void)jit_bnei_i(reffail, JIT_R2, scheme_vector_type); + jit_ldxi_i(JIT_R2, JIT_R0, (int)&SCHEME_VEC_SIZE(0x0)); + } else { + (void)jit_bnei_i(reffail, JIT_R2, scheme_flvector_type); + jit_ldxi_l(JIT_R2, JIT_R0, (int)&SCHEME_FLVEC_SIZE(0x0)); + } if (!int_ready) { jit_rshi_ul(JIT_V1, JIT_R1, 1); (void)jit_bler_ul(reffail, JIT_R2, JIT_V1); @@ -5589,6 +5949,15 @@ static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready, int (void)jit_bler_ul(reffail, JIT_R2, JIT_R1); } CHECK_LIMIT(); + + if (for_fl && set) { + jit_ldr_p(JIT_R2, JIT_RUNSTACK); + (void)jit_bmsi_ul(reffail, JIT_R2, 0x1); + jit_ldxi_s(JIT_R2, JIT_R2, &((Scheme_Object *)0x0)->type); + (void)jit_bnei_i(reffail, JIT_R2, scheme_double_type); + CHECK_LIMIT(); + } + __END_TINY_JUMPS__(1); } else { if (!int_ready) @@ -5596,15 +5965,28 @@ static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready, int } if (!int_ready) { - jit_lshi_ul(JIT_V1, JIT_V1, JIT_LOG_WORD_SIZE); + if (!for_fl) + jit_lshi_ul(JIT_V1, JIT_V1, JIT_LOG_WORD_SIZE); + else + jit_lshi_ul(JIT_V1, JIT_V1, JIT_LOG_DOUBLE_SIZE); jit_addi_p(JIT_V1, JIT_V1, base_offset); } if (set) { jit_ldr_p(JIT_R2, JIT_RUNSTACK); - jit_stxr_p(JIT_V1, JIT_R0, JIT_R2); + if (!for_fl) { + jit_stxr_p(JIT_V1, JIT_R0, JIT_R2); + } else { + jit_ldxi_d_fppush(JIT_FPR0, JIT_R2, &((Scheme_Double *)0x0)->double_val); + jit_stxr_d_fppop(JIT_V1, JIT_R0, JIT_FPR0); + } (void)jit_movi_p(JIT_R0, scheme_void); } else { - jit_ldxr_p(JIT_R0, JIT_R0, JIT_V1); + if (!for_fl) { + jit_ldxr_p(JIT_R0, JIT_R0, JIT_V1); + } else { + jit_ldxr_d_fppush(JIT_FPR0, JIT_R0, JIT_V1); + generate_alloc_double(jitter); + } } return 1; @@ -5652,7 +6034,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i mz_runstack_skipped(jitter, 2); - generate_non_tail(a2, jitter, 0, 1); + generate_non_tail(a2, jitter, 0, 1, 0); CHECK_LIMIT(); if (need_sync) mz_rs_sync(); @@ -5712,134 +6094,134 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i return 1; } else if (IS_NAMED_PRIM(rator, "=")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 0, 0, for_branch, branch_short, 0, 0); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 0, 0, for_branch, branch_short, 0, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "unsafe-fx=")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 0, 0, for_branch, branch_short, 1, 0); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 0, 0, for_branch, branch_short, 1, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "unsafe-fl=")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 0, 0, for_branch, branch_short, 0, 1); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 0, 0, for_branch, branch_short, 0, 1, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "<=")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, -1, 0, for_branch, branch_short, 0, 0); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, -1, 0, for_branch, branch_short, 0, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "unsafe-fx<=")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, -1, 0, for_branch, branch_short, 1, 0); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, -1, 0, for_branch, branch_short, 1, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "unsafe-fl<=")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, -1, 0, for_branch, branch_short, 0, 1); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, -1, 0, for_branch, branch_short, 0, 1, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "<")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, -2, 0, for_branch, branch_short, 0, 0); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, -2, 0, for_branch, branch_short, 0, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "unsafe-fx<")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, -2, 0, for_branch, branch_short, 1, 0); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, -2, 0, for_branch, branch_short, 1, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "unsafe-fl<")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, -2, 0, for_branch, branch_short, 0, 1); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, -2, 0, for_branch, branch_short, 0, 1, NULL); return 1; } else if (IS_NAMED_PRIM(rator, ">=")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 1, 0, for_branch, branch_short, 0, 0); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 1, 0, for_branch, branch_short, 0, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "unsafe-fx>=")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 1, 0, for_branch, branch_short, 1, 0); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 1, 0, for_branch, branch_short, 1, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "unsafe-fl>=")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 1, 0, for_branch, branch_short, 0, 1); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 1, 0, for_branch, branch_short, 0, 1, NULL); return 1; } else if (IS_NAMED_PRIM(rator, ">")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 2, 0, for_branch, branch_short, 0, 0); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 2, 0, for_branch, branch_short, 0, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "unsafe-fx>")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 2, 0, for_branch, branch_short, 1, 0); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 2, 0, for_branch, branch_short, 1, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "unsafe-fl>")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 2, 0, for_branch, branch_short, 0, 1); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 2, 0, for_branch, branch_short, 0, 1, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "bitwise-bit-set?")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 3, 0, for_branch, branch_short, 0, 0); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, 0, 3, 0, for_branch, branch_short, 0, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "char=?")) { generate_binary_char(jitter, app, for_branch, branch_short); return 1; } else if (!for_branch) { if (IS_NAMED_PRIM(rator, "+")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, 1, 0, 0, NULL, 1, 0, 0); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, 1, 0, 0, NULL, 1, 0, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "unsafe-fx+")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, 1, 0, 0, NULL, 1, 1, 0); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, 1, 0, 0, NULL, 1, 1, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "unsafe-fl+")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, 1, 0, 0, NULL, 1, 0, 1); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, 1, 0, 0, NULL, 1, 0, 1, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "-")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, -1, 0, 0, NULL, 1, 0, 0); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, -1, 0, 0, NULL, 1, 0, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "unsafe-fx-")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, -1, 0, 0, NULL, 1, 1, 0); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, -1, 0, 0, NULL, 1, 1, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "unsafe-fl-")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, -1, 0, 0, NULL, 1, 0, 1); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, -1, 0, 0, NULL, 1, 0, 1, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "*")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, 2, 0, 0, NULL, 1, 0, 0); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, 2, 0, 0, NULL, 1, 0, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "unsafe-fx*")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, 2, 0, 0, NULL, 1, 1, 0); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, 2, 0, 0, NULL, 1, 1, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "unsafe-fl*")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, 2, 0, 0, NULL, 1, 0, 1); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, 2, 0, 0, NULL, 1, 0, 1, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "/")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, -2, 0, 0, NULL, 1, 0, 0); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, -2, 0, 0, NULL, 1, 0, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "unsafe-fl/")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, -2, 0, 0, NULL, 1, 0, 1); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, -2, 0, 0, NULL, 1, 0, 1, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "quotient")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, -3, 0, 0, NULL, 1, 0, 0); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, -3, 0, 0, NULL, 1, 0, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "unsafe-fxquotient")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, -3, 0, 0, NULL, 1, 1, 0); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, -3, 0, 0, NULL, 1, 1, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "remainder")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, -4, 0, 0, NULL, 1, 0, 0); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, -4, 0, 0, NULL, 1, 0, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "unsafe-fxremainder")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, -4, 0, 0, NULL, 1, 1, 0); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, -4, 0, 0, NULL, 1, 1, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "min")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, 9, 0, 0, NULL, 1, 0, 0); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, 9, 0, 0, NULL, 1, 0, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "max")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, 10, 0, 0, NULL, 1, 0, 0); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, 10, 0, 0, NULL, 1, 0, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "bitwise-and")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, 3, 0, 0, NULL, 1, 0, 0); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, 3, 0, 0, NULL, 1, 0, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "unsafe-fxand")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, 3, 0, 0, NULL, 1, 1, 0); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, 3, 0, 0, NULL, 1, 1, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "bitwise-ior")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, 4, 0, 0, NULL, 1, 0, 0); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, 4, 0, 0, NULL, 1, 0, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "unsafe-fxior")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, 4, 0, 0, NULL, 1, 1, 0); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, 4, 0, 0, NULL, 1, 1, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "bitwise-xor")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, 5, 0, 0, NULL, 1, 0, 0); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, 5, 0, 0, NULL, 1, 0, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "unsafe-fxxor")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, 5, 0, 0, NULL, 1, 1, 0); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, 5, 0, 0, NULL, 1, 1, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "arithmetic-shift")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, 6, 0, 0, NULL, 1, 0, 0); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, 6, 0, 0, NULL, 1, 0, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "unsafe-fxlshift")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, 6, 0, 0, NULL, 1, 1, 0); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, 6, 0, 0, NULL, 1, 1, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "unsafe-fxrshift")) { - generate_arith(jitter, rator, app->rand1, app->rand2, 2, -6, 0, 0, NULL, 1, 1, 0); + generate_arith(jitter, rator, app->rand1, app->rand2, 2, -6, 0, 0, NULL, 1, 1, 0, NULL); return 1; } else if (IS_NAMED_PRIM(rator, "vector-ref") || IS_NAMED_PRIM(rator, "unsafe-vector-ref") @@ -5847,7 +6229,8 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i || IS_NAMED_PRIM(rator, "string-ref") || IS_NAMED_PRIM(rator, "unsafe-string-ref") || IS_NAMED_PRIM(rator, "bytes-ref") - || IS_NAMED_PRIM(rator, "unsafe-bytes-ref")) { + || IS_NAMED_PRIM(rator, "unsafe-bytes-ref") + || IS_NAMED_PRIM(rator, "flvector-ref")) { int simple; int which, unsafe = 0, base_offset = ((int)&SCHEME_VEC_ELS(0x0)); @@ -5856,6 +6239,9 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i else if (IS_NAMED_PRIM(rator, "unsafe-vector-ref")) { which = 0; unsafe = 1; + } else if (IS_NAMED_PRIM(rator, "flvector-ref")) { + which = 3; + base_offset = ((int)&SCHEME_FLVEC_ELS(0x0)); } else if (IS_NAMED_PRIM(rator, "unsafe-struct-ref")) { which = 0; unsafe = 1; @@ -5885,7 +6271,11 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i if (!which) { /* vector-ref is relatively simple and worth inlining */ - generate_vector_op(jitter, 0, 0, base_offset, unsafe); + generate_vector_op(jitter, 0, 0, base_offset, 0, unsafe); + CHECK_LIMIT(); + } else if (which == 3) { + /* flvector-ref is relatively simple and worth inlining */ + generate_vector_op(jitter, 0, 0, base_offset, 1, unsafe); CHECK_LIMIT(); } else if (which == 1) { if (unsafe) { @@ -5918,7 +6308,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i mz_runstack_skipped(jitter, 2); - generate_non_tail(app->rand1, jitter, 0, 1); + generate_non_tail(app->rand1, jitter, 0, 1, 0); CHECK_LIMIT(); mz_rs_sync(); @@ -5928,12 +6318,18 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i (void)jit_movi_p(JIT_R1, offset); if (!which) offset = base_offset + WORDS_TO_BYTES(offset); + else if (which == 3) + offset = base_offset + (offset * sizeof(double)); else if (which == 1) offset = offset << LOG_MZCHAR_SIZE; jit_movi_l(JIT_V1, offset); if (!which) { /* vector-ref is relatively simple and worth inlining */ - generate_vector_op(jitter, 0, 1, base_offset, unsafe); + generate_vector_op(jitter, 0, 1, base_offset, 0, unsafe); + CHECK_LIMIT(); + } else if (which == 3) { + /* flvector-ref is relatively simple and worth inlining */ + generate_vector_op(jitter, 0, 1, base_offset, 1, unsafe); CHECK_LIMIT(); } else if (which == 1) { if (unsafe) { @@ -5961,6 +6357,44 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i mz_runstack_unskipped(jitter, 2); } + return 1; + } else if (IS_NAMED_PRIM(rator, "unsafe-f64vector-ref") + || IS_NAMED_PRIM(rator, "unsafe-flvector-ref")) { + int fpr0, unbox = jitter->unbox; + int is_f64; + + is_f64 = IS_NAMED_PRIM(rator, "unsafe-f64vector-ref"); + + jitter->unbox = 0; /* no unboxing of vector and index arguments */ + generate_two_args(app->rand1, app->rand2, jitter, 1, 2); + jitter->unbox = unbox; + CHECK_LIMIT(); + + if (is_f64) { + jit_ldxi_p(JIT_R0, JIT_R0, (long)&(((Scheme_Structure *)0x0)->slots[0])); + jit_ldxi_p(JIT_R0, JIT_R0, (long)&SCHEME_CPTR_VAL(0x0)); + } + jit_rshi_ul(JIT_R1, JIT_R1, 1); + jit_lshi_ul(JIT_R1, JIT_R1, JIT_LOG_DOUBLE_SIZE); + if (!is_f64) { + jit_addi_ul(JIT_R1, JIT_R1, (int)(&SCHEME_FLVEC_ELS(0x0))); + } + + if (jitter->unbox) + fpr0 = JIT_FPR(jitter->unbox_depth); + else + fpr0 = JIT_FPR0; + + jit_ldxr_d_fppush(fpr0, JIT_R0, JIT_R1); + CHECK_LIMIT(); + + if (jitter->unbox) + jitter->unbox_depth++; + else { + mz_rs_sync(); + generate_alloc_double(jitter); + } + return 1; } else if (IS_NAMED_PRIM(rator, "set-mcar!") || IS_NAMED_PRIM(rator, "set-mcdr!")) { @@ -6119,9 +6553,25 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int scheme_direct_call_count++; - if (!for_branch) { + if (IS_NAMED_PRIM(rator, "=")) { + generate_nary_arith(jitter, app, 0, 0, for_branch, branch_short); + return 1; + } else if (IS_NAMED_PRIM(rator, "<")) { + generate_nary_arith(jitter, app, 0, -2, for_branch, branch_short); + return 1; + } else if (IS_NAMED_PRIM(rator, ">")) { + generate_nary_arith(jitter, app, 0, 2, for_branch, branch_short); + return 1; + } else if (IS_NAMED_PRIM(rator, "<=")) { + generate_nary_arith(jitter, app, 0, -1, for_branch, branch_short); + return 1; + } else if (IS_NAMED_PRIM(rator, ">=")) { + generate_nary_arith(jitter, app, 0, 1, for_branch, branch_short); + return 1; + } else if (!for_branch) { if (IS_NAMED_PRIM(rator, "vector-set!") || IS_NAMED_PRIM(rator, "unsafe-vector-set!") + || IS_NAMED_PRIM(rator, "flvector-set!") || IS_NAMED_PRIM(rator, "unsafe-struct-set!") || IS_NAMED_PRIM(rator, "string-set!") || IS_NAMED_PRIM(rator, "unsafe-string-set!") @@ -6136,6 +6586,9 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int else if (IS_NAMED_PRIM(rator, "unsafe-vector-set!")) { which = 0; unsafe = 1; + } else if (IS_NAMED_PRIM(rator, "flvector-set!")) { + which = 3; + base_offset = ((int)&SCHEME_FLVEC_ELS(0x0)); } else if (IS_NAMED_PRIM(rator, "unsafe-struct-set!")) { which = 0; unsafe = 1; @@ -6173,7 +6626,7 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int CHECK_LIMIT(); } - generate_non_tail(app->args[1], jitter, 0, 1); /* sync'd below */ + generate_non_tail(app->args[1], jitter, 0, 1, 0); /* sync'd below */ CHECK_LIMIT(); if (!constval || !simple) { mz_rs_str(JIT_R0); @@ -6182,7 +6635,7 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int } if (!simple) { - generate_non_tail(app->args[2], jitter, 0, 1); /* sync'd below */ + generate_non_tail(app->args[2], jitter, 0, 1, 0); /* sync'd below */ CHECK_LIMIT(); if (!constval) { mz_rs_stxi(1, JIT_R0); @@ -6191,7 +6644,7 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int } } - generate_non_tail(app->args[3], jitter, 0, 1); /* sync'd below */ + generate_non_tail(app->args[3], jitter, 0, 1, 0); /* sync'd below */ CHECK_LIMIT(); mz_rs_sync(); @@ -6210,7 +6663,11 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int if (!simple) { if (!which) { /* vector-set! is relatively simple and worth inlining */ - generate_vector_op(jitter, 1, 0, base_offset, unsafe); + generate_vector_op(jitter, 1, 0, base_offset, 0, unsafe); + CHECK_LIMIT(); + } else if (which == 3) { + /* flvector-set! is relatively simple and worth inlining */ + generate_vector_op(jitter, 1, 0, base_offset, 1, unsafe); CHECK_LIMIT(); } else if (which == 1) { if (unsafe) { @@ -6242,12 +6699,18 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int (void)jit_movi_p(JIT_R1, offset); if (!which) offset = base_offset + WORDS_TO_BYTES(offset); + else if (which == 3) + offset = base_offset + (offset * sizeof(double)); else if (which == 1) offset = offset << LOG_MZCHAR_SIZE; jit_movi_l(JIT_V1, offset); if (!which) { /* vector-set! is relatively simple and worth inlining */ - generate_vector_op(jitter, 1, 1, base_offset, unsafe); + generate_vector_op(jitter, 1, 1, base_offset, 0, unsafe); + CHECK_LIMIT(); + } else if (which == 3) { + /* flvector-set! is relatively simple and worth inlining */ + generate_vector_op(jitter, 1, 1, base_offset, 1, unsafe); CHECK_LIMIT(); } else if (which == 1) { if (unsafe) { @@ -6277,6 +6740,67 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int mz_runstack_unskipped(jitter, 3 - pushed); + return 1; + } else if (IS_NAMED_PRIM(rator, "unsafe-f64vector-set!") + || IS_NAMED_PRIM(rator, "unsafe-flvector-set!")) { + int is_f64; + is_f64 = IS_NAMED_PRIM(rator, "unsafe-f64vector-set!"); + if (can_unbox(app->args[3], 5, JIT_FPR_NUM-1)) { + int got_two; + if (is_constant_and_avoids_r1(app->args[1]) + && is_constant_and_avoids_r1(app->args[2])) { + mz_runstack_skipped(jitter, 3); + got_two = 0; + } else { + got_two = 1; + mz_runstack_skipped(jitter, 1); + generate_app(app, NULL, 2, jitter, 0, 0, 2); + } + jitter->unbox++; + generate(app->args[3], jitter, 0, 0, JIT_R0); /* to FP reg */ + CHECK_LIMIT(); + --jitter->unbox; + jitter->unbox_depth -= 1; + if (!got_two) { + generate(app->args[2], jitter, 0, 0, JIT_R1); + CHECK_LIMIT(); + generate(app->args[1], jitter, 0, 0, JIT_R0); + mz_runstack_unskipped(jitter, 3); + } else { + mz_rs_ldr(JIT_R0); + mz_rs_ldxi(JIT_R1, 1); + mz_rs_inc(2); /* no sync */ + mz_runstack_popped(jitter, 2); + mz_runstack_unskipped(jitter, 1); + } + } else { + generate_app(app, NULL, 3, jitter, 0, 0, 2); + CHECK_LIMIT(); + + mz_rs_ldxi(JIT_R0, 2); + jit_ldxi_d_fppush(JIT_FPR0, JIT_R0, &((Scheme_Double *)0x0)->double_val); + mz_rs_ldr(JIT_R0); + mz_rs_ldxi(JIT_R1, 1); + + mz_rs_inc(3); /* no sync */ + mz_runstack_popped(jitter, 3); + } + CHECK_LIMIT(); + + if (is_f64) { + jit_ldxi_p(JIT_R0, JIT_R0, (long)&(((Scheme_Structure *)0x0)->slots[0])); + jit_ldxi_p(JIT_R0, JIT_R0, (long)&SCHEME_CPTR_VAL(0x0)); + } + jit_rshi_ul(JIT_R1, JIT_R1, 1); + jit_lshi_ul(JIT_R1, JIT_R1, JIT_LOG_DOUBLE_SIZE); + if (!is_f64) { + jit_addi_ul(JIT_R1, JIT_R1, (int)(&SCHEME_FLVEC_ELS(0x0))); + } + jit_stxr_d_fppop(JIT_R1, JIT_R0, JIT_FPR0); + CHECK_LIMIT(); + + (void)jit_movi_p(JIT_R0, scheme_void); + return 1; } else if (IS_NAMED_PRIM(rator, "vector-immutable") || IS_NAMED_PRIM(rator, "vector")) { @@ -6318,6 +6842,24 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int } return 1; + } else if (IS_NAMED_PRIM(rator, "+")) { + return generate_nary_arith(jitter, app, 1, 0, NULL, 1); + } else if (IS_NAMED_PRIM(rator, "-")) { + return generate_nary_arith(jitter, app, -1, 0, NULL, 1); + } else if (IS_NAMED_PRIM(rator, "*")) { + return generate_nary_arith(jitter, app, 2, 0, NULL, 1); + } else if (IS_NAMED_PRIM(rator, "/")) { + return generate_nary_arith(jitter, app, -2, 0, NULL, 1); + } else if (IS_NAMED_PRIM(rator, "bitwise-and")) { + return generate_nary_arith(jitter, app, 3, 0, NULL, 1); + } else if (IS_NAMED_PRIM(rator, "bitwise-ior")) { + return generate_nary_arith(jitter, app, 4, 0, NULL, 1); + } else if (IS_NAMED_PRIM(rator, "bitwise-xor")) { + return generate_nary_arith(jitter, app, 5, 0, NULL, 1); + } else if (IS_NAMED_PRIM(rator, "min")) { + return generate_nary_arith(jitter, app, 9, 0, NULL, 1); + } else if (IS_NAMED_PRIM(rator, "max")) { + return generate_nary_arith(jitter, app, 10, 0, NULL, 1); } else if (IS_NAMED_PRIM(rator, "checked-procedure-check-and-extract")) { generate_app(app, NULL, 5, jitter, 0, 0, 2); /* sync'd below */ CHECK_LIMIT(); @@ -6388,7 +6930,7 @@ static int generate_vector_alloc(mz_jit_state *jitter, Scheme_Object *rator, if (app2) { mz_runstack_skipped(jitter, 1); - generate_non_tail(app2->rand, jitter, 0, 1); /* sync'd below */ + generate_non_tail(app2->rand, jitter, 0, 1, 0); /* sync'd below */ CHECK_LIMIT(); mz_runstack_unskipped(jitter, 1); c = 1; @@ -6713,14 +7255,15 @@ static void generate_non_tail_mark_pos_suffix(mz_jit_state *jitter) mz_tl_sti_l(tl_scheme_current_cont_mark_pos, JIT_R2, JIT_R0); } -static int generate_non_tail(Scheme_Object *obj, mz_jit_state *jitter, int multi_ok, int mark_pos_ends) +static int generate_non_tail(Scheme_Object *obj, mz_jit_state *jitter, + int multi_ok, int mark_pos_ends, int ignored) /* de-sync's rs */ { if (is_simple(obj, INIT_SIMPLE_DEPTH, 0, jitter, 0)) { /* Simple; doesn't change the stack or set marks: */ int v; FOR_LOG(jitter->log_depth++); - v = generate(obj, jitter, 0, multi_ok, JIT_R0); + v = generate(obj, jitter, 0, multi_ok, ignored ? -1 : JIT_R0); FOR_LOG(--jitter->log_depth); return v; } @@ -6755,7 +7298,7 @@ static int generate_non_tail(Scheme_Object *obj, mz_jit_state *jitter, int multi PAUSE_JIT_DATA(); FOR_LOG(jitter->log_depth++); - generate(obj, jitter, 0, multi_ok, JIT_R0); /* no sync */ + generate(obj, jitter, 0, multi_ok, ignored ? -1 : JIT_R0); /* no sync */ FOR_LOG(--jitter->log_depth); RESUME_JIT_DATA(); @@ -6789,28 +7332,6 @@ static int generate_non_tail(Scheme_Object *obj, mz_jit_state *jitter, int multi /* expression codegen */ /*========================================================================*/ -static int generate_ignored_non_tail(Scheme_Object *obj, mz_jit_state *jitter, int multi_ok, int need_ends) -/* de-sync's */ -{ - Scheme_Type t = SCHEME_TYPE(obj); - - if (SAME_TYPE(t, scheme_local_type) - || SAME_TYPE(t, scheme_local_unbox_type)) { - /* Must be here to clear */ - if (SCHEME_LOCAL_FLAGS(obj) & SCHEME_LOCAL_CLEAR_ON_READ) { - int pos; - START_JIT_DATA(); - pos = mz_remap(SCHEME_LOCAL_POS(obj)); - LOG_IT(("clear %d\n", pos)); - mz_rs_stxi(pos, JIT_RUNSTACK); - END_JIT_DATA(2); - } - return 1; - } - - return generate_non_tail(obj, jitter, multi_ok, need_ends); -} - static Scheme_Object *generate_k(void) { Scheme_Thread *p = scheme_current_thread; @@ -6830,6 +7351,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m /* de-sync's; result goes to target */ { Scheme_Type type; + int result_ignored, orig_target; #ifdef DO_STACK_CHECK # include "mzstkchk.h" @@ -6857,34 +7379,44 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m return SCHEME_INT_VAL(ok); } #endif + + orig_target = target; + result_ignored = (target < 0); + if (target < 0) target = JIT_R0; type = SCHEME_TYPE(obj); switch (type) { case scheme_toplevel_type: { - int pos; + int can_fail; /* Other parts of the JIT rely on this code not modifying R1 */ - START_JIT_DATA(); - LOG_IT(("top-level\n")); - mz_rs_sync_fail_branch(); - /* Load global array: */ - pos = mz_remap(SCHEME_TOPLEVEL_DEPTH(obj)); - mz_rs_ldxi(JIT_R2, pos); - /* Load bucket: */ - pos = SCHEME_TOPLEVEL_POS(obj); - jit_ldxi_p(JIT_R2, JIT_R2, WORDS_TO_BYTES(pos)); - /* Extract bucket value */ - jit_ldxi_p(target, JIT_R2, &(SCHEME_VAR_BUCKET(0x0)->val)); - CHECK_LIMIT(); - if (!(SCHEME_TOPLEVEL_FLAGS(obj) - & (SCHEME_TOPLEVEL_CONST | SCHEME_TOPLEVEL_READY))) { - /* Is it NULL? */ - generate_pop_unboxed(jitter); + can_fail = !(SCHEME_TOPLEVEL_FLAGS(obj) + & (SCHEME_TOPLEVEL_CONST | SCHEME_TOPLEVEL_READY)); + if (!can_fail && result_ignored) { + /* skip */ + } else { + int pos; + START_JIT_DATA(); + LOG_IT(("top-level\n")); + mz_rs_sync_fail_branch(); + /* Load global array: */ + pos = mz_remap(SCHEME_TOPLEVEL_DEPTH(obj)); + mz_rs_ldxi(JIT_R2, pos); + /* Load bucket: */ + pos = SCHEME_TOPLEVEL_POS(obj); + jit_ldxi_p(JIT_R2, JIT_R2, WORDS_TO_BYTES(pos)); + /* Extract bucket value */ + jit_ldxi_p(target, JIT_R2, &(SCHEME_VAR_BUCKET(0x0)->val)); CHECK_LIMIT(); - (void)jit_beqi_p(unbound_global_code, target, 0); + if (can_fail) { + /* Is it NULL? */ + generate_pop_unboxed(jitter); + CHECK_LIMIT(); + (void)jit_beqi_p(unbound_global_code, target, 0); + } + if (jitter->unbox) generate_unboxing(jitter); + END_JIT_DATA(0); } - if (jitter->unbox) generate_unboxing(jitter); - END_JIT_DATA(0); return 1; } case scheme_local_type: @@ -6894,11 +7426,13 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m START_JIT_DATA(); pos = mz_remap(SCHEME_LOCAL_POS(obj)); LOG_IT(("local %d [%d]\n", pos, SCHEME_LOCAL_FLAGS(obj))); - if (pos || (mz_CURRENT_STATUS() != mz_RS_R0_HAS_RUNSTACK0)) { - mz_rs_ldxi(target, pos); - VALIDATE_RESULT(target); - } else if (target != JIT_R0) { - jit_movr_p(target, JIT_R0); + if (!result_ignored) { + if (pos || (mz_CURRENT_STATUS() != mz_RS_R0_HAS_RUNSTACK0)) { + mz_rs_ldxi(target, pos); + VALIDATE_RESULT(target); + } else if (target != JIT_R0) { + jit_movr_p(target, JIT_R0); + } } if (SCHEME_LOCAL_FLAGS(obj) & SCHEME_LOCAL_CLEAR_ON_READ) { mz_rs_stxi(pos, JIT_RUNSTACK); @@ -6915,8 +7449,10 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m LOG_IT(("unbox local\n")); pos = mz_remap(SCHEME_LOCAL_POS(obj)); - mz_rs_ldxi(JIT_R0, pos); - jit_ldr_p(target, JIT_R0); + if (!result_ignored) { + mz_rs_ldxi(JIT_R0, pos); + jit_ldr_p(target, JIT_R0); + } if (SCHEME_LOCAL_FLAGS(obj) & SCHEME_LOCAL_CLEAR_ON_READ) { LOG_IT(("clear-on-read\n")); mz_rs_stxi(pos, JIT_RUNSTACK); @@ -6955,7 +7491,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m /* Evaluate first expression, and for consistency with bytecode evaluation, allow multiple values. */ - generate_non_tail(seq->array[0], jitter, 1, 1); + generate_non_tail(seq->array[0], jitter, 1, 1, 0); CHECK_LIMIT(); /* Save value(s) */ @@ -6994,7 +7530,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m mz_patch_branch(ref2); __END_SHORT_JUMPS__(1); for (i = 1; i < seq->count; i++) { - generate_ignored_non_tail(seq->array[i], jitter, 1, 1); /* sync's below */ + generate_non_tail(seq->array[i], jitter, 1, 1, 1); /* sync's below */ CHECK_LIMIT(); } @@ -7036,7 +7572,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m v = SCHEME_CAR(p); p = SCHEME_CDR(p); - generate_non_tail(p, jitter, 0, 1); + generate_non_tail(p, jitter, 0, 1, 0); CHECK_LIMIT(); mz_rs_sync(); @@ -7074,7 +7610,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m v = SCHEME_CAR(p); p = SCHEME_CDR(p); - generate_non_tail(v, jitter, 0, 1); + generate_non_tail(v, jitter, 0, 1, 0); CHECK_LIMIT(); /* If v is not known to produce a procedure, then check result: */ @@ -7088,7 +7624,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m } mz_pushr_p(JIT_R0); - generate_non_tail(p, jitter, 1, 1); + generate_non_tail(p, jitter, 1, 1, 0); CHECK_LIMIT(); mz_popr_p(JIT_V1); @@ -7227,7 +7763,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m jit_stxi_p(WORDS_TO_BYTES(pos), JIT_RUNSTACK, JIT_R0); CHECK_LIMIT(); - generate(p, jitter, is_tail, multi_ok, target); + generate(p, jitter, is_tail, multi_ok, orig_target); END_JIT_DATA(8); } @@ -7364,19 +7900,20 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m LOG_IT(("begin\n")); for (i = 0; i < cnt - 1; i++) { - generate_ignored_non_tail(seq->array[i], jitter, 1, 1); + generate_non_tail(seq->array[i], jitter, 1, 1, 1); CHECK_LIMIT(); } END_JIT_DATA(11); - return generate(seq->array[cnt - 1], jitter, is_tail, multi_ok, target); + return generate(seq->array[cnt - 1], jitter, is_tail, multi_ok, orig_target); } case scheme_branch_type: { Scheme_Branch_Rec *branch = (Scheme_Branch_Rec *)obj; jit_insn *refs[6], *ref2; int nsrs, nsrs1, g1, g2, amt, need_sync; + int else_is_empty = 0; #ifdef NEED_LONG_JUMPS int then_short_ok, else_short_ok; #else @@ -7410,9 +7947,13 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m else need_sync = 1; + if (result_ignored + && (SCHEME_TYPE(branch->fbranch) > _scheme_compiled_values_types_)) + else_is_empty = 1; + if (!generate_inlined_test(jitter, branch->test, then_short_ok, refs, need_sync)) { CHECK_LIMIT(); - generate_non_tail(branch->test, jitter, 0, 1); + generate_non_tail(branch->test, jitter, 0, 1, 0); if (need_sync) mz_rs_sync(); CHECK_LIMIT(); __START_SHORT_JUMPS__(then_short_ok); @@ -7427,7 +7968,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m PAUSE_JIT_DATA(); LOG_IT(("...then...\n")); FOR_LOG(++jitter->log_depth); - g1 = generate(branch->tbranch, jitter, is_tail, multi_ok, target); + g1 = generate(branch->tbranch, jitter, is_tail, multi_ok, orig_target); RESUME_JIT_DATA(); CHECK_LIMIT(); amt = mz_runstack_restored(jitter); @@ -7438,7 +7979,10 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m if (need_sync) mz_rs_sync(); } __START_SHORT_JUMPS__(else_short_ok); - ref2 = jit_jmpi(jit_forward()); + if (else_is_empty) + ref2 = NULL; + else + ref2 = jit_jmpi(jit_forward()); __END_SHORT_JUMPS__(else_short_ok); nsrs1 = jitter->need_set_rs; } else { @@ -7474,7 +8018,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m FOR_LOG(jitter->log_depth--); LOG_IT(("...else\n")); FOR_LOG(++jitter->log_depth); - g2 = generate(branch->fbranch, jitter, is_tail, multi_ok, target); + g2 = generate(branch->fbranch, jitter, is_tail, multi_ok, orig_target); RESUME_JIT_DATA(); CHECK_LIMIT(); amt = mz_runstack_restored(jitter); @@ -7489,7 +8033,9 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m } if (g1 != 2) { __START_SHORT_JUMPS__(else_short_ok); - mz_patch_ucbranch(ref2); + if (!else_is_empty) { + mz_patch_ucbranch(ref2); + } __END_SHORT_JUMPS__(else_short_ok); } FOR_LOG(jitter->log_depth--); @@ -7538,7 +8084,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m if (lv->count == 1) { /* Expect one result: */ - generate_non_tail(lv->value, jitter, 0, 1); /* no sync */ + generate_non_tail(lv->value, jitter, 0, 1, 0); /* no sync */ CHECK_LIMIT(); if (ab) { pos = mz_remap(lv->position); @@ -7553,7 +8099,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m /* Expect multiple results: */ jit_insn *ref, *ref2, *ref3; - generate_non_tail(lv->value, jitter, 1, 1); + generate_non_tail(lv->value, jitter, 1, 1, 0); CHECK_LIMIT(); mz_rs_sync(); @@ -7593,7 +8139,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m CHECK_LIMIT(); /* Continue with expected values; R2 has value array: */ - mz_patch_branch(ref2); + mz_patch_branch(ref2); __END_SHORT_JUMPS__(1); for (i = 0; i < lv->count; i++) { jit_ldxi_p(JIT_R1, JIT_R2, WORDS_TO_BYTES(i)); @@ -7613,7 +8159,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m LOG_IT(("...in\n")); - return generate(lv->body, jitter, is_tail, multi_ok, target); + return generate(lv->body, jitter, is_tail, multi_ok, orig_target); } case scheme_let_void_type: { @@ -7648,7 +8194,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m LOG_IT(("...in\n")); - return generate(lv->body, jitter, is_tail, multi_ok, target); + return generate(lv->body, jitter, is_tail, multi_ok, orig_target); } case scheme_letrec_type: { @@ -7703,7 +8249,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m jitter->need_set_rs = nsrs; } - return generate(l->body, jitter, is_tail, multi_ok, target); + return generate(l->body, jitter, is_tail, multi_ok, orig_target); } case scheme_let_one_type: { @@ -7715,7 +8261,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m mz_runstack_skipped(jitter, 1); PAUSE_JIT_DATA(); - generate_non_tail(lv->value, jitter, 0, 1); /* no sync */ + generate_non_tail(lv->value, jitter, 0, 1, 0); /* no sync */ RESUME_JIT_DATA(); CHECK_LIMIT(); @@ -7733,7 +8279,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m mz_RECORD_STATUS(mz_RS_R0_HAS_RUNSTACK0); - return generate(lv->body, jitter, is_tail, multi_ok, target); + return generate(lv->body, jitter, is_tail, multi_ok, orig_target); } case scheme_with_cont_mark_type: { @@ -7743,16 +8289,16 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m LOG_IT(("wcm...\n")); /* Key: */ - generate_non_tail(wcm->key, jitter, 0, 1); /* sync'd below */ + generate_non_tail(wcm->key, jitter, 0, 1, 0); /* sync'd below */ CHECK_LIMIT(); if (SCHEME_TYPE(wcm->val) > _scheme_values_types_) { /* No need to push mark onto value stack: */ jit_movr_p(JIT_V1, JIT_R0); - generate_non_tail(wcm->val, jitter, 0, 1); /* sync'd below */ + generate_non_tail(wcm->val, jitter, 0, 1, 0); /* sync'd below */ CHECK_LIMIT(); } else { mz_pushr_p(JIT_R0); - generate_non_tail(wcm->val, jitter, 0, 1); /* sync'd below */ + generate_non_tail(wcm->val, jitter, 0, 1, 0); /* sync'd below */ CHECK_LIMIT(); mz_popr_p(JIT_V1); /* sync'd below */ } @@ -7770,7 +8316,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m LOG_IT(("...in\n")); - return generate(wcm->body, jitter, is_tail, multi_ok, target); + return generate(wcm->body, jitter, is_tail, multi_ok, orig_target); } case scheme_quote_syntax_type: { @@ -7807,7 +8353,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m jit_movi_d_fppush(fpr0, d); jitter->unbox_depth++; return 1; - } else { + } else if (!result_ignored) { int retptr; Scheme_Type type = SCHEME_TYPE(obj); START_JIT_DATA(); @@ -7847,6 +8393,8 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m END_JIT_DATA(19); return 1; + } else { + return 1; } } } @@ -8210,6 +8758,16 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) CHECK_LIMIT(); register_sub_func(jitter, bad_vector_length_code, scheme_false); + /* *** bad_flvector_length_code *** */ + /* R0 is argument */ + bad_flvector_length_code = jit_get_ip().ptr; + mz_prolog(JIT_R1); + jit_prepare(1); + jit_pusharg_i(JIT_R0); + (void)mz_finish(ts_scheme_flvector_length); + CHECK_LIMIT(); + register_sub_func(jitter, bad_flvector_length_code, scheme_false); + /* *** call_original_unary_arith_code *** */ /* R0 is arg, R2 is code pointer, V1 is return address */ for (i = 0; i < 3; i++) { @@ -8257,7 +8815,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) { /* May use JIT_R0 and create local branch: */ mz_generate_direct_prim(jit_pusharg_p(JIT_RUNSTACK), - jit_pusharg_p(JIT_R1), + jit_pusharg_i(JIT_R1), JIT_R2, noncm_prim_indirect); } CHECK_LIMIT(); @@ -8283,6 +8841,32 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) } } + /* *** call_original_nary_arith_code *** */ + /* rator is in V1, count is in R1, args are on runstack */ + { + void *code; + + code = jit_get_ip().ptr; + call_original_nary_arith_code = code; + + mz_prolog(JIT_R2); + JIT_UPDATE_THREAD_RSPTR(); + mz_prepare_direct_prim(2); + { + /* May use JIT_R0 and create local branch: */ + mz_generate_direct_prim(jit_pusharg_p(JIT_RUNSTACK), + jit_pusharg_i(JIT_R1), + JIT_V1, noncm_prim_indirect); + } + CHECK_LIMIT(); + jit_retval(JIT_R0); + VALIDATE_RESULT(JIT_R0); + mz_epilog(JIT_R2); + CHECK_LIMIT(); + + register_sub_func(jitter, code, scheme_false); + } + /* *** on_demand_jit_[arity_]code *** */ /* Used as the code stub for a closure whose code is not yet compiled. See generate_function_prolog @@ -8684,6 +9268,40 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) } } + /* *** {flvector}_{ref,set}_check_index_code *** */ + /* Same calling convention as for vector ops. */ + for (i = 0; i < 2; i++) { + if (!i) { + flvector_ref_check_index_code = jit_get_ip().ptr; + } else { + flvector_set_check_index_code = jit_get_ip().ptr; + } + + mz_prolog(JIT_R2); + + jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(2)); + CHECK_RUNSTACK_OVERFLOW(); + jit_str_p(JIT_RUNSTACK, JIT_R0); + jit_stxi_p(WORDS_TO_BYTES(1), JIT_RUNSTACK, JIT_R1); + if (!i) { + jit_movi_i(JIT_R1, 2); + } else { + /* In set mode, value was already on run stack */ + jit_movi_i(JIT_R1, 3); + } + JIT_UPDATE_THREAD_RSPTR(); + jit_prepare(2); + jit_pusharg_p(JIT_RUNSTACK); + jit_pusharg_i(JIT_R1); + if (!i) { + (void)mz_finish(ts_scheme_checked_flvector_ref); + } else { + (void)mz_finish(ts_scheme_checked_flvector_set); + } + /* does not return */ + } + + /* *** syntax_ecode *** */ /* R0 is (potential) syntax object */ { diff --git a/src/mzscheme/src/jit_ts.c b/src/mzscheme/src/jit_ts.c index a43e0e5827..640e456944 100644 --- a/src/mzscheme/src/jit_ts.c +++ b/src/mzscheme/src/jit_ts.c @@ -60,6 +60,7 @@ define_ts_iS_s(scheme_checked_set_mcar, FSRC_OTHER) define_ts_iS_s(scheme_checked_set_mcdr, FSRC_OTHER) define_ts_s_s(scheme_unbox, FSRC_OTHER) define_ts_s_s(scheme_vector_length, FSRC_OTHER) +define_ts_s_s(scheme_flvector_length, FSRC_OTHER) define_ts_s_s(tail_call_with_values_from_multiple_result, FSRC_OTHER) define_ts_s_v(raise_bad_call_with_values, FSRC_OTHER) define_ts_s_s(call_with_values_from_multiple_result_multi, FSRC_OTHER) @@ -70,6 +71,8 @@ define_ts_iS_s(scheme_checked_string_ref, FSRC_OTHER) define_ts_iS_s(scheme_checked_string_set, FSRC_OTHER) define_ts_iS_s(scheme_checked_byte_string_ref, FSRC_OTHER) define_ts_iS_s(scheme_checked_byte_string_set, FSRC_OTHER) +define_ts_iS_s(scheme_checked_flvector_ref, FSRC_OTHER) +define_ts_iS_s(scheme_checked_flvector_set, FSRC_OTHER) define_ts_iS_s(scheme_checked_syntax_e, FSRC_OTHER) define_ts_iS_s(scheme_extract_checked_procedure, FSRC_OTHER) define_ts_S_s(apply_checked_fail, FSRC_OTHER) @@ -120,6 +123,7 @@ define_ts_siS_v(wrong_argument_count, FSRC_OTHER) # define ts_scheme_checked_set_mcdr scheme_checked_set_mcdr # define ts_scheme_unbox scheme_unbox # define ts_scheme_vector_length scheme_vector_length +# define ts_scheme_flvector_length scheme_flvector_length # define ts_tail_call_with_values_from_multiple_result tail_call_with_values_from_multiple_result # define ts_raise_bad_call_with_values raise_bad_call_with_values # define ts_call_with_values_from_multiple_result_multi call_with_values_from_multiple_result_multi @@ -130,6 +134,8 @@ define_ts_siS_v(wrong_argument_count, FSRC_OTHER) # define ts_scheme_checked_string_set scheme_checked_string_set # define ts_scheme_checked_byte_string_ref scheme_checked_byte_string_ref # define ts_scheme_checked_byte_string_set scheme_checked_byte_string_set +# define ts_scheme_checked_flvector_ref scheme_checked_flvector_ref +# define ts_scheme_checked_flvector_set scheme_checked_flvector_set # define ts_scheme_checked_syntax_e scheme_checked_syntax_e # define ts_scheme_extract_checked_procedure scheme_extract_checked_procedure # define ts_apply_checked_fail apply_checked_fail diff --git a/src/mzscheme/src/lightning/i386/fp.h b/src/mzscheme/src/lightning/i386/fp.h index d9f54757ff..a36f5e205d 100644 --- a/src/mzscheme/src/lightning/i386/fp.h +++ b/src/mzscheme/src/lightning/i386/fp.h @@ -201,6 +201,8 @@ union jit_double_imm { ((rd) == 0 ? (FSTPr (0), FPX(), FLDLm(0, (s1), (s2), 1)) \ : (FPX(), FLDLm(0, (s1), (s2), 1), FSTPr ((rd) + 1))) +#define jit_ldxr_d_fppush(rd, s1, s2) (FPX(), FLDLm(0, (s1), (s2), 1)) + #define jit_extr_i_d(rd, rs) (PUSHLr((rs)), \ ((rd) == 0 ? (FSTPr (0), FILDLm(0, _ESP, 0, 0)) \ : (FILDLm(0, _ESP, 0, 0), FSTPr ((rd) + 1))), \ @@ -235,9 +237,10 @@ union jit_double_imm { #define jit_sti_d_fppop(id, rs) (FPX(), FSTPLm((id), 0, 0, 0)) #endif -#define jit_stxi_d_fppop(id, rd, rs) (FPX(), FSTPLm((id), (rd), 0, 0)) +#define jit_stxi_d_fppop(id, rd, rs) (FPX(), FSTPLm((id), (rd), 0, 0)) #define jit_str_d_fppop(rd, rs) (FPX(), FSTPLm(0, (rd), 0, 0)) +#define jit_stxr_d_fppop(d1, d2, rs) (FPX(), FSTPLm(0, (d1), (d2), 1)) /* Assume round to near mode */ #define jit_floorr_d_i(rd, rs) \ diff --git a/src/mzscheme/src/mzmark.c b/src/mzscheme/src/mzmark.c index 5ff15d2952..a302d65f43 100644 --- a/src/mzscheme/src/mzmark.c +++ b/src/mzscheme/src/mzmark.c @@ -1449,6 +1449,34 @@ static int vector_obj_FIXUP(void *p) { #define vector_obj_IS_CONST_SIZE 0 +static int flvector_obj_SIZE(void *p) { + Scheme_Double_Vector *vec = (Scheme_Double_Vector *)p; + + return + gcBYTES_TO_WORDS((sizeof(Scheme_Double_Vector) + + ((vec->size - 1) * sizeof(double)))); +} + +static int flvector_obj_MARK(void *p) { + Scheme_Double_Vector *vec = (Scheme_Double_Vector *)p; + + return + gcBYTES_TO_WORDS((sizeof(Scheme_Double_Vector) + + ((vec->size - 1) * sizeof(double)))); +} + +static int flvector_obj_FIXUP(void *p) { + Scheme_Double_Vector *vec = (Scheme_Double_Vector *)p; + + return + gcBYTES_TO_WORDS((sizeof(Scheme_Double_Vector) + + ((vec->size - 1) * sizeof(double)))); +} + +#define flvector_obj_IS_ATOMIC 1 +#define flvector_obj_IS_CONST_SIZE 0 + + static int input_port_SIZE(void *p) { return gcBYTES_TO_WORDS(sizeof(Scheme_Input_Port)); @@ -3582,7 +3610,7 @@ static int mark_input_fd_FIXUP(void *p) { #endif -#if defined(UNIX_PROCESSES) +#if defined(UNIX_PROCESSES) && !(defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)) static int mark_system_child_SIZE(void *p) { return gcBYTES_TO_WORDS(sizeof(System_Child)); diff --git a/src/mzscheme/src/mzmarksrc.c b/src/mzscheme/src/mzmarksrc.c index e850efbb0b..a16deaaff4 100644 --- a/src/mzscheme/src/mzmarksrc.c +++ b/src/mzscheme/src/mzmarksrc.c @@ -546,6 +546,15 @@ vector_obj { + ((vec->size - 1) * sizeof(Scheme_Object *)))); } +flvector_obj { + Scheme_Double_Vector *vec = (Scheme_Double_Vector *)p; + + mark: + size: + gcBYTES_TO_WORDS((sizeof(Scheme_Double_Vector) + + ((vec->size - 1) * sizeof(double)))); +} + input_port { mark: Scheme_Input_Port *ip = (Scheme_Input_Port *)p; diff --git a/src/mzscheme/src/mzrt.c b/src/mzscheme/src/mzrt.c index c92b6d75ae..2cf35c6197 100644 --- a/src/mzscheme/src/mzrt.c +++ b/src/mzscheme/src/mzrt.c @@ -35,6 +35,12 @@ START_XFORM_SUSPEND; # endif #endif +#ifndef MZ_PRECISE_GC +int GC_pthread_join(pthread_t thread, void **retval); +int GC_pthread_create(pthread_t *thread, const pthread_attr_t *attr, void *(*start_routine)(void*), void * arg); +int GC_pthread_detach(pthread_t thread); +#endif + void mzrt_set_user_break_handler(void (*user_break_handler)(int)) { #ifdef WIN32 @@ -66,7 +72,8 @@ static void rungdb() { case 'd': snprintf(outbuffer, 100, "xterm -e gdb ./mzscheme3m %d &", pid); fprintf(stderr, "%s\n", outbuffer); - system(outbuffer); + if(system(outbuffer)) + fprintf(stderr, "system failed\n"); break; case 'e': default: @@ -156,6 +163,7 @@ void *mzrt_thread_stub(void *data){ mzrt_thread_stub_data *stub_data = (mzrt_thread_stub_data*) data; void * (*start_proc)(void *) = stub_data->start_proc; void *start_proc_data = stub_data->data; + scheme_init_os_thread(); proc_thread_self = stub_data->thread; free(data); @@ -188,6 +196,17 @@ mz_proc_thread* mzrt_proc_first_thread_init() { mz_proc_thread* mz_proc_thread_create(mz_proc_thread_start start_proc, void* data) { mz_proc_thread *thread = (mz_proc_thread*)malloc(sizeof(mz_proc_thread)); + pthread_attr_t *attr; + +#ifdef OS_X + pthread_attr_t attr_storage; + attr = &attr_storage; + pthread_attr_init(attr); + pthread_attr_setstacksize(attr, 8*1024*1024); /*8MB*/ +#else + attr = NULL; +#endif + #ifdef MZ_PRECISE_GC mzrt_thread_stub_data *stub_data = (mzrt_thread_stub_data*)malloc(sizeof(mzrt_thread_stub_data)); thread->mbox = pt_mbox_create(); @@ -197,13 +216,13 @@ mz_proc_thread* mz_proc_thread_create(mz_proc_thread_start start_proc, void* dat # ifdef WIN32 thread->threadid = CreateThread(NULL, 0, start_proc, data, 0, NULL); # else - pthread_create(&thread->threadid, NULL, mzrt_thread_stub, stub_data); + pthread_create(&thread->threadid, attr, mzrt_thread_stub, stub_data); # endif #else # ifdef WIN32 thread->threadid = GC_CreateThread(NULL, 0, start_proc, data, 0, NULL); # else - GC_pthread_create(&thread->threadid, NULL, start_proc, data); + GC_pthread_create(&thread->threadid, attr, start_proc, data); # endif #endif return thread; @@ -226,6 +245,21 @@ void * mz_proc_thread_wait(mz_proc_thread *thread) { #endif } +int mz_proc_thread_detach(mz_proc_thread *thread) { +#ifdef WIN32 + DWORD rc; + return (void *) rc; +#else + int rc; +# ifndef MZ_PRECISE_GC + rc = GC_pthread_detach(thread->threadid); +# else + rc = pthread_detach(thread->threadid); +# endif + return rc; +#endif +} + /***********************************************************************/ /* RW Lock */ /***********************************************************************/ diff --git a/src/mzscheme/src/mzrt.h b/src/mzscheme/src/mzrt.h index f97ae6e579..751239405c 100644 --- a/src/mzscheme/src/mzrt.h +++ b/src/mzscheme/src/mzrt.h @@ -42,6 +42,7 @@ typedef void *(mz_proc_thread_start)(void*); mz_proc_thread* mzrt_proc_first_thread_init(); mz_proc_thread* mz_proc_thread_create(mz_proc_thread_start*, void* data); void *mz_proc_thread_wait(mz_proc_thread *thread); +int mz_proc_thread_detach(mz_proc_thread *thread); void mzrt_sleep(int seconds); diff --git a/src/mzscheme/src/numarith.c b/src/mzscheme/src/numarith.c index a090f37e6c..605b894782 100644 --- a/src/mzscheme/src/numarith.c +++ b/src/mzscheme/src/numarith.c @@ -63,20 +63,24 @@ void scheme_init_numarith(Scheme_Env *env) scheme_add_global_constant("sub1", p, env); p = scheme_make_folding_prim(plus, "+", 0, -1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_NARY_INLINED); scheme_add_global_constant("+", p, env); p = scheme_make_folding_prim(minus, "-", 1, -1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED - | SCHEME_PRIM_IS_UNARY_INLINED); + | SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_IS_NARY_INLINED); scheme_add_global_constant("-", p, env); p = scheme_make_folding_prim(mult, "*", 0, -1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_NARY_INLINED); scheme_add_global_constant("*", p, env); p = scheme_make_folding_prim(div_prim, "/", 1, -1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_NARY_INLINED); scheme_add_global_constant("/", p, env); p = scheme_make_folding_prim(scheme_abs, "abs", 1, 1, 1); diff --git a/src/mzscheme/src/number.c b/src/mzscheme/src/number.c index dbd681096d..5e5f6171f4 100644 --- a/src/mzscheme/src/number.c +++ b/src/mzscheme/src/number.c @@ -98,6 +98,11 @@ static Scheme_Object *angle (int argc, Scheme_Object *argv[]); static Scheme_Object *int_sqrt (int argc, Scheme_Object *argv[]); static Scheme_Object *int_sqrt_rem (int argc, Scheme_Object *argv[]); +static Scheme_Object *flvector (int argc, Scheme_Object *argv[]); +static Scheme_Object *flvector_p (int argc, Scheme_Object *argv[]); +static Scheme_Object *flvector_length (int argc, Scheme_Object *argv[]); +static Scheme_Object *make_flvector (int argc, Scheme_Object *argv[]); + static Scheme_Object *fx_and (int argc, Scheme_Object *argv[]); static Scheme_Object *fx_or (int argc, Scheme_Object *argv[]); static Scheme_Object *fx_xor (int argc, Scheme_Object *argv[]); @@ -105,6 +110,12 @@ static Scheme_Object *fx_not (int argc, Scheme_Object *argv[]); static Scheme_Object *fx_lshift (int argc, Scheme_Object *argv[]); static Scheme_Object *fx_rshift (int argc, Scheme_Object *argv[]); static Scheme_Object *fx_to_fl (int argc, Scheme_Object *argv[]); +static Scheme_Object *fl_ref (int argc, Scheme_Object *argv[]); +static Scheme_Object *fl_set (int argc, Scheme_Object *argv[]); + +static Scheme_Object *unsafe_flvector_length (int argc, Scheme_Object *argv[]); +static Scheme_Object *unsafe_flvector_ref (int argc, Scheme_Object *argv[]); +static Scheme_Object *unsafe_flvector_set (int argc, Scheme_Object *argv[]); static double not_a_number_val; @@ -282,7 +293,7 @@ scheme_init_number (Scheme_Env *env) SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; scheme_add_global_constant("exact-positive-integer?", p, env); - p = scheme_make_noncm_prim(fixnum_p, "fixnum?", 1, 1); + p = scheme_make_immed_prim(fixnum_p, "fixnum?", 1, 1); SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; scheme_add_global_constant("fixnum?", p, env); @@ -312,15 +323,18 @@ scheme_init_number (Scheme_Env *env) env); p = scheme_make_folding_prim(scheme_bitwise_and, "bitwise-and", 0, -1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_NARY_INLINED); scheme_add_global_constant("bitwise-and", p, env); p = scheme_make_folding_prim(bitwise_or, "bitwise-ior", 0, -1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_NARY_INLINED); scheme_add_global_constant("bitwise-ior", p, env); p = scheme_make_folding_prim(bitwise_xor, "bitwise-xor", 0, -1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_NARY_INLINED); scheme_add_global_constant("bitwise-xor", p, env); p = scheme_make_folding_prim(bitwise_not, "bitwise-not", 1, 1, 1); @@ -491,6 +505,39 @@ scheme_init_number (Scheme_Env *env) "inexact->exact", 1, 1, 1), env); + + scheme_add_global_constant("flvector", + scheme_make_prim_w_arity(flvector, + "flvector", + 0, -1), + env); + scheme_add_global_constant("flvector?", + scheme_make_folding_prim(flvector_p, + "flvector?", + 1, 1, 1), + env); + scheme_add_global_constant("make-flvector", + scheme_make_immed_prim(make_flvector, + "make-flvector", + 1, 2), + env); + + p = scheme_make_immed_prim(flvector_length, "flvector-length", 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; + scheme_add_global_constant("flvector-length", p, env); + + p = scheme_make_immed_prim(scheme_checked_flvector_ref, + "flvector-ref", + 2, 2); + if (scheme_can_inline_fp_op()) + SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + scheme_add_global_constant("flvector-ref", p, env); + + p = scheme_make_immed_prim(scheme_checked_flvector_set, + "flvector-set!", + 3, 3); + SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED; + scheme_add_global_constant("flvector-set!", p, env); } void scheme_init_unsafe_number(Scheme_Env *env) @@ -525,8 +572,35 @@ void scheme_init_unsafe_number(Scheme_Env *env) if (scheme_can_inline_fp_op()) SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; scheme_add_global_constant("unsafe-fx->fl", p, env); -} + p = scheme_make_immed_prim(fl_ref, "unsafe-f64vector-ref", + 2, 2); + if (scheme_can_inline_fp_op()) + SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + scheme_add_global_constant("unsafe-f64vector-ref", p, env); + + p = scheme_make_immed_prim(fl_set, "unsafe-f64vector-set!", + 3, 3); + if (scheme_can_inline_fp_op()) + SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED; + scheme_add_global_constant("unsafe-f64vector-set!", p, env); + + p = scheme_make_immed_prim(unsafe_flvector_length, "unsafe-flvector-length", + 1, 1); + SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; + scheme_add_global_constant("unsafe-flvector-length", p, env); + + p = scheme_make_immed_prim(unsafe_flvector_ref, "unsafe-flvector-ref", + 2, 2); + if (scheme_can_inline_fp_op()) + SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + scheme_add_global_constant("unsafe-flvector-ref", p, env); + + p = scheme_make_immed_prim(unsafe_flvector_set, "unsafe-flvector-set!", + 3, 3); + SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED; + scheme_add_global_constant("unsafe-flvector-set!", p, env); +} Scheme_Object * @@ -2770,6 +2844,156 @@ long scheme_integer_length(Scheme_Object *n) return SCHEME_INT_VAL(r); } + +/************************************************************************/ +/* flvectors */ +/************************************************************************/ + +static Scheme_Double_Vector *alloc_flvector(long size) +{ + Scheme_Double_Vector *vec; + + vec = (Scheme_Double_Vector *)scheme_malloc_fail_ok(scheme_malloc_atomic_tagged, + sizeof(Scheme_Double_Vector) + + ((size - 1) * sizeof(double))); + vec->so.type = scheme_flvector_type; + vec->size = size; + + return vec; +} + +static Scheme_Object *flvector (int argc, Scheme_Object *argv[]) +{ + int i; + Scheme_Double_Vector *vec; + + for (i = 0; i < argc; i++) { + if (!SCHEME_FLOATP(argv[i])) { + scheme_wrong_type("flvector", "inexact real", i, argc, argv); + return NULL; + } + } + + vec = alloc_flvector(argc); + + for (i = 0; i < argc; i++) { + vec->els[i] = SCHEME_FLOAT_VAL(argv[i]); + } + + return (Scheme_Object *)vec; +} + + +static Scheme_Object *flvector_p (int argc, Scheme_Object *argv[]) +{ + if (SCHEME_FLVECTORP(argv[0])) + return scheme_true; + else + return scheme_false; +} + +static Scheme_Object *make_flvector (int argc, Scheme_Object *argv[]) +{ + Scheme_Double_Vector *vec; + long size; + + if (SCHEME_INTP(argv[0])) + size = SCHEME_INT_VAL(argv[0]); + else if (SCHEME_BIGNUMP(argv[0])) { + if (SCHEME_BIGPOS(argv[0])) { + scheme_raise_out_of_memory("make-flvector", NULL); + return NULL; + } else + size = -1; + } else + size = -1; + + if (size < 0) + scheme_wrong_type("make-flvector", "exact non-negative integer", 0, argc, argv); + + if (argc > 1) { + if (!SCHEME_FLOATP(argv[1])) + scheme_wrong_type("make-flvector", "inexact real", 1, argc, argv); + } + + vec = alloc_flvector(size); + + if (argc > 1) { + int i; + double d = SCHEME_FLOAT_VAL(argv[1]); + for (i = 0; i < size; i++) { + vec->els[i] = d; + } + } + + return (Scheme_Object *)vec; +} + +Scheme_Object *scheme_flvector_length(Scheme_Object *vec) +{ + if (!SCHEME_FLVECTORP(vec)) + scheme_wrong_type("flvector-length", "flvector", 0, 1, &vec); + + return scheme_make_integer(SCHEME_FLVEC_SIZE(vec)); +} + +static Scheme_Object *flvector_length (int argc, Scheme_Object *argv[]) +{ + return scheme_flvector_length(argv[0]); +} + +Scheme_Object *scheme_checked_flvector_ref (int argc, Scheme_Object *argv[]) +{ + double d; + Scheme_Object *vec; + long len, pos; + + vec = argv[0]; + if (!SCHEME_FLVECTORP(vec)) + scheme_wrong_type("flvector-ref", "flvector", 0, argc, argv); + + len = SCHEME_FLVEC_SIZE(vec); + pos = scheme_extract_index("flvector-ref", 1, argc, argv, len, 0); + + if (pos >= len) { + scheme_bad_vec_index("flvector-ref", argv[1], + "flvector", vec, + 0, len); + return NULL; + } + + d = SCHEME_FLVEC_ELS(vec)[pos]; + + return scheme_make_double(d); +} + +Scheme_Object *scheme_checked_flvector_set (int argc, Scheme_Object *argv[]) +{ + Scheme_Object *vec; + long len, pos; + + vec = argv[0]; + if (!SCHEME_FLVECTORP(vec)) + scheme_wrong_type("flvector-set!", "flvector", 0, argc, argv); + + len = SCHEME_FLVEC_SIZE(vec); + pos = scheme_extract_index("flvector-set!", 1, argc, argv, len, 0); + + if (!SCHEME_FLOATP(argv[2])) + scheme_wrong_type("flvector-set!", "inexact real", 2, argc, argv); + + if (pos >= len) { + scheme_bad_vec_index("flvector-set!", argv[1], + "flvector", vec, + 0, len); + return NULL; + } + + SCHEME_FLVEC_ELS(vec)[pos] = SCHEME_FLOAT_VAL(argv[2]); + + return scheme_void; +} + /************************************************************************/ /* Unsafe */ /************************************************************************/ @@ -2814,3 +3038,46 @@ static Scheme_Object *fx_to_fl (int argc, Scheme_Object *argv[]) v = SCHEME_INT_VAL(argv[0]); return scheme_make_double(v); } + +static Scheme_Object *fl_ref (int argc, Scheme_Object *argv[]) +{ + double v; + Scheme_Object *p; + p = ((Scheme_Structure *)argv[0])->slots[0]; + v = ((double *)SCHEME_CPTR_VAL(p))[SCHEME_INT_VAL(argv[1])]; + return scheme_make_double(v); +} + +static Scheme_Object *fl_set (int argc, Scheme_Object *argv[]) +{ + Scheme_Object *p; + p = ((Scheme_Structure *)argv[0])->slots[0]; + ((double *)SCHEME_CPTR_VAL(p))[SCHEME_INT_VAL(argv[1])] = SCHEME_DBL_VAL(argv[2]); + return scheme_void; +} + +static Scheme_Object *unsafe_flvector_length (int argc, Scheme_Object *argv[]) +{ + return scheme_make_integer(SCHEME_FLVEC_SIZE(argv[0])); +} + +static Scheme_Object *unsafe_flvector_ref (int argc, Scheme_Object *argv[]) +{ + long pos; + double d; + + pos = SCHEME_INT_VAL(argv[1]); + d = SCHEME_FLVEC_ELS(argv[0])[pos]; + + return scheme_make_double(d); +} + +static Scheme_Object *unsafe_flvector_set (int argc, Scheme_Object *argv[]) +{ + long pos; + + pos = SCHEME_INT_VAL(argv[1]); + SCHEME_FLVEC_ELS(argv[0])[pos] = SCHEME_FLOAT_VAL(argv[2]); + + return scheme_void; +} diff --git a/src/mzscheme/src/numcomp.c b/src/mzscheme/src/numcomp.c index 6e678070d6..1095be750e 100644 --- a/src/mzscheme/src/numcomp.c +++ b/src/mzscheme/src/numcomp.c @@ -57,23 +57,28 @@ void scheme_init_numcomp(Scheme_Env *env) Scheme_Object *p; p = scheme_make_folding_prim(eq, "=", 2, -1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_NARY_INLINED); scheme_add_global_constant("=", p, env); p = scheme_make_folding_prim(lt, "<", 2, -1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_BINARY_INLINED); scheme_add_global_constant("<", p, env); p = scheme_make_folding_prim(gt, ">", 2, -1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_NARY_INLINED); scheme_add_global_constant(">", p, env); p = scheme_make_folding_prim(lt_eq, "<=", 2, -1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_NARY_INLINED); scheme_add_global_constant("<=", p, env); p = scheme_make_folding_prim(gt_eq, ">=", 2, -1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_NARY_INLINED); scheme_add_global_constant(">=", p, env); p = scheme_make_folding_prim(zero_p, "zero?", 1, 1, 1); @@ -89,11 +94,13 @@ void scheme_init_numcomp(Scheme_Env *env) scheme_add_global_constant("negative?", p, env); p = scheme_make_folding_prim(sch_max, "max", 1, -1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_NARY_INLINED); scheme_add_global_constant("max", p, env); p = scheme_make_folding_prim(sch_min, "min", 1, -1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_NARY_INLINED); scheme_add_global_constant("min", p, env); } diff --git a/src/mzscheme/src/places.c b/src/mzscheme/src/places.c index 49abf639f8..ae92403141 100644 --- a/src/mzscheme/src/places.c +++ b/src/mzscheme/src/places.c @@ -39,6 +39,7 @@ static Scheme_Object *not_implemented(int argc, Scheme_Object **argv) # ifdef MZ_PRECISE_GC static void register_traversers(void) { } + # endif #endif @@ -132,14 +133,211 @@ Scheme_Object *scheme_place(int argc, Scheme_Object *args[]) { return (Scheme_Object*) place; } +#ifdef MZ_PRECISE_GC +/*============= SIGNAL HANDLER =============*/ +#include +#include +#include +#include + + +static void error_info() { + char *erstr; + erstr = strerror(errno); + printf("errno %i %s\n", errno, erstr); +} + +typedef struct Child_Status { + int pid; + int status; + void *signal_fd; + struct Child_Status *next; +} Child_Status; + +static Child_Status *child_statuses = NULL; +static mzrt_mutex* child_status_lock = NULL; + +static void add_child_status(int pid, int status) { + Child_Status *st; + st = malloc(sizeof(Child_Status)); + st->pid = pid; + st->signal_fd = NULL; + st->status = status; + + mzrt_mutex_lock(child_status_lock); + st->next = child_statuses; + child_statuses = st; + mzrt_mutex_unlock(child_status_lock); +} + +static int raw_get_child_status(int pid, int *status) { + Child_Status *st; + Child_Status *prev; + int found = 0; + + for (st = child_statuses, prev = NULL; st; prev = st, st = st->next) { + if (st->pid == pid) { + *status = st->status; + found = 1; + if (prev) { + prev->next = st->next; + } + else { + child_statuses = st->next; + } + free(st); + break; + } + } + return found; +} + +int scheme_get_child_status(int pid, int *status) { + int found = 0; + mzrt_mutex_lock(child_status_lock); + found = raw_get_child_status(pid, status); + mzrt_mutex_unlock(child_status_lock); + /* printf("scheme_get_child_status found %i pid %i status %i\n", found, pid, *status); */ + return found; +} + +int scheme_places_register_child(int pid, void *signal_fd, int *status) { + int found = 0; + + mzrt_mutex_lock(child_status_lock); + found = raw_get_child_status(pid, status); + if (!found) { + Child_Status *st; + st = malloc(sizeof(Child_Status)); + st->pid = pid; + st->signal_fd = signal_fd; + st->status = 0; + + st->next = child_statuses; + child_statuses = st; + } + mzrt_mutex_unlock(child_status_lock); + return found; +} + +static void *mz_proc_thread_signal_worker(void *data) { + int status; + int pid; + sigset_t set; + //GC_CAN_IGNORE siginfo_t info; + { + sigemptyset(&set); + sigaddset(&set, SIGCHLD); + pthread_sigmask(SIG_UNBLOCK, &set, NULL); + } + + while(1) { + int rc; + int signalid; + do { + rc = sigwait(&set, &signalid); + if (rc == -1) { + if (errno != EINTR ) { + error_info(); + } + } + } while (rc == -1 && errno == EINTR); + + pid = waitpid((pid_t)-1, &status, WNOHANG); + if (pid == -1) { + char *erstr; + erstr = strerror(errno); + /* printf("errno %i %s\n", errno, erstr); */ + } + else { + /* printf("SIGCHILD pid %i with status %i %i\n", pid, status, WEXITSTATUS(status)); */ + add_child_status(pid, status); + } + }; + return NULL; +} + + +void scheme_places_block_child_signal() { + { + sigset_t set; + sigemptyset(&set); + sigaddset(&set, SIGCHLD); + pthread_sigmask(SIG_BLOCK, &set, NULL); + } + + { + mz_proc_thread *signal_thread; + mzrt_mutex_create(&child_status_lock); + signal_thread = mz_proc_thread_create(mz_proc_thread_signal_worker, NULL); + mz_proc_thread_detach(signal_thread); + } +} + +/*============= THREAD JOIN HANDLER =============*/ +typedef struct { + mz_proc_thread *proc_thread; + Scheme_Place *waiting_place; + int *wake_fd; + int ready; + long rc; +} proc_thread_wait_data; + + +static void *mz_proc_thread_wait_worker(void *data) { + void *rc; + proc_thread_wait_data *wd = (proc_thread_wait_data*) data; + + rc = mz_proc_thread_wait(wd->proc_thread); + wd->rc = (long) rc; + wd->ready = 1; + scheme_signal_received_at(wd->wake_fd); + return NULL; +} + +static int place_wait_ready(Scheme_Object *o) { + proc_thread_wait_data *wd = (proc_thread_wait_data*) o; + if (wd->ready) { + return 1; + } + return 0; +} +#endif + static Scheme_Object *scheme_place_wait(int argc, Scheme_Object *args[]) { - void *rc; Scheme_Place *place; place = (Scheme_Place *) args[0]; + +#ifdef MZ_PRECISE_GC + { + Scheme_Object *rc; + mz_proc_thread *worker_thread; + Scheme_Place *waiting_place; + int *wake_fd; - rc = mz_proc_thread_wait((mz_proc_thread *)place->proc_thread); - - return scheme_void; + proc_thread_wait_data *wd; + wd = (proc_thread_wait_data*) malloc(sizeof(proc_thread_wait_data)); + wd->proc_thread = (mz_proc_thread *)place->proc_thread; + wd->waiting_place = waiting_place; + wake_fd = scheme_get_signal_handle(); + wd->wake_fd = wake_fd; + wd->ready = 0; + + worker_thread = mz_proc_thread_create(mz_proc_thread_wait_worker, wd); + mz_proc_thread_detach(worker_thread); + scheme_block_until(place_wait_ready, NULL, (Scheme_Object *) wd, 1.0); + + rc = scheme_make_integer((long)wd->rc); + free(wd); + return rc; + } +#else + { + void *rcvoid; + rcvoid = mz_proc_thread_wait((mz_proc_thread *)place->proc_thread); + return scheme_make_integer((long) rcvoid); + } +#endif } static Scheme_Object *scheme_place_p(int argc, Scheme_Object *args[]) @@ -181,6 +379,9 @@ Scheme_Object *scheme_places_deep_copy(Scheme_Object *so) case scheme_char_string_type: /*43*/ new_so = scheme_make_sized_offset_char_string(SCHEME_CHAR_STR_VAL(so), 0, SCHEME_CHAR_STRLEN_VAL(so), 1); break; + case scheme_byte_string_type: + new_so = scheme_make_sized_offset_byte_string(SCHEME_BYTE_STR_VAL(so), 0, SCHEME_BYTE_STRLEN_VAL(so), 1); + break; case scheme_unix_path_type: new_so = scheme_make_sized_offset_path(SCHEME_BYTE_STR_VAL(so), 0, SCHEME_BYTE_STRLEN_VAL(so), 1); break; @@ -226,16 +427,14 @@ static void *place_start_proc(void *data_arg) { stack_base = PROMPT_STACK(stack_base); place_data = (Place_Start_Data *) data_arg; - printf("Startin place: proc thread id%u\n", ptid); + /* printf("Startin place: proc thread id%u\n", ptid); */ /* create pristine THREAD_LOCAL variables*/ null_out_runtime_globals(); /* scheme_make_thread behaves differently if the above global vars are not null */ -#ifdef MZ_PRECISE_GC - GC_construct_child_gc(); -#endif scheme_place_instance_init(stack_base); + a[0] = place_data->current_library_collection_paths; scheme_current_library_collection_paths(1, a); @@ -271,6 +470,8 @@ Scheme_Object *scheme_places_deep_copy_in_master(Scheme_Object *so) { #ifdef MZ_PRECISE_GC static void* scheme_master_place_handlemsg(int msg_type, void *msg_payload); + +#if 0 static void *master_scheme_place(void *data) { mz_proc_thread *myself; myself = proc_thread_self; @@ -288,6 +489,7 @@ static void *master_scheme_place(void *data) { } return NULL; } +#endif static void* scheme_master_place_handlemsg(int msg_type, void *msg_payload) { @@ -333,12 +535,12 @@ void* scheme_master_fast_path(int msg_type, void *msg_payload) { } -void spawn_master_scheme_place() { +void scheme_spawn_master_place() { mzrt_proc_first_thread_init(); - //scheme_master_proc_thread = mz_proc_thread_create(master_scheme_place, NULL); - scheme_master_proc_thread = ~0; + /* scheme_master_proc_thread = mz_proc_thread_create(master_scheme_place, NULL); */ + scheme_master_proc_thread = (void*) ~0; } #endif diff --git a/src/mzscheme/src/port.c b/src/mzscheme/src/port.c index be14d99b34..b265a2accd 100644 --- a/src/mzscheme/src/port.c +++ b/src/mzscheme/src/port.c @@ -169,7 +169,7 @@ int scheme_stupid_windows_machine; /******************** Unix Subprocesses ********************/ -#if defined(UNIX_PROCESSES) +#if defined(UNIX_PROCESSES) && !(defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)) /* For process & system: */ typedef struct System_Child { MZTAG_IF_REQUIRED @@ -186,6 +186,10 @@ typedef struct Scheme_Subprocess { Scheme_Object so; void *handle; int pid; +#if defined(UNIX_PROCESSES) && defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) + short done; + int status; +#endif } Scheme_Subprocess; #ifdef USE_FD_PORTS @@ -486,7 +490,7 @@ scheme_init_port (Scheme_Env *env) REGISTER_SO(scheme_null_output_port_type); REGISTER_SO(scheme_redirect_output_port_type); -#if defined(UNIX_PROCESSES) +#if defined(UNIX_PROCESSES) && !(defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)) REGISTER_SO(scheme_system_children); #endif @@ -6787,7 +6791,7 @@ static int MyPipe(int *ph, int near_index) { /**************** Unix: signal stuff ******************/ -#if defined(UNIX_PROCESSES) +#if defined(UNIX_PROCESSES) && !(defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)) # define WAITANY(s) waitpid((pid_t)-1, s, WNOHANG) @@ -6800,6 +6804,7 @@ static int need_to_check_children; void scheme_block_child_signals(int block) XFORM_SKIP_PROC { +#if !(defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)) sigset_t sigs; sigemptyset(&sigs); @@ -6808,6 +6813,7 @@ void scheme_block_child_signals(int block) sigaddset(&sigs, SIGPROF); #endif sigprocmask(block ? SIG_BLOCK : SIG_UNBLOCK, &sigs, NULL); +#endif } static void child_done(int ingored) @@ -6825,6 +6831,7 @@ static int sigchld_installed = 0; static void init_sigchld(void) { +#if !(defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)) if (!sigchld_installed) { /* Catch child-done signals */ START_XFORM_SKIP; @@ -6833,6 +6840,7 @@ static void init_sigchld(void) sigchld_installed = 1; } +#endif } static void check_child_done() @@ -7073,24 +7081,47 @@ scheme_make_redirect_output_port(Scheme_Object *port) #if defined(UNIX_PROCESSES) || defined(WINDOWS_PROCESSES) -static int subp_done(Scheme_Object *sp) +static int subp_done(Scheme_Object *so) { - void *sci = ((Scheme_Subprocess *)sp)->handle; + Scheme_Subprocess *sp; + sp = (Scheme_Subprocess*) so; #if defined(UNIX_PROCESSES) - System_Child *sc = (System_Child *)sci; - check_child_done(); - return sc->done; -#endif -#ifdef WINDOWS_PROCESSES - DWORD w; - if (sci) { - if (GetExitCodeProcess((HANDLE)sci, &w)) - return w != STILL_ACTIVE; +# if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) + { + int status; + if(! sp->done) { + if(scheme_get_child_status(((Scheme_Subprocess *)sp)->pid, &status)) { + sp->done = 1; + sp->status = status; + return 1; + } + return 0; + } else return 1; - } else - return 1; + } +# else + { + System_Child *sc; + sc = ((System_Child *) ((Scheme_Subprocess *)sp)->handle); + check_child_done(); + return sc->done; + } +# endif +#endif +#ifdef WINDOWS_PROCESSES + { + HANDLE sci = (HANDLE) ((Scheme_Subprocess *)sp)->handle; + DWORD w; + if (sci) { + if (GetExitCodeProcess(sci, &w)) + return w != STILL_ACTIVE; + else + return 1; + } else + return 1; + } #endif } @@ -7116,14 +7147,23 @@ static Scheme_Object *subprocess_status(int argc, Scheme_Object **argv) int going = 0, status = MZ_FAILURE_STATUS; #if defined(UNIX_PROCESSES) - System_Child *sc = (System_Child *)sp->handle; - - check_child_done(); - - if (sc->done) - status = sc->status; - else +# if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) + if (sp->done) + status = sp->status; + else { + if(!scheme_get_child_status(((Scheme_Subprocess *)sp)->pid, &status)) { going = 1; + } + } +# else + System_Child *sc = (System_Child *)sp->handle; + check_child_done(); + + if (sc->done) + status = sc->status; + else + going = 1; +# endif #else # ifdef WINDOWS_PROCESSES DWORD w; @@ -7189,23 +7229,34 @@ static Scheme_Object *subprocess_kill(int argc, Scheme_Object **argv) Scheme_Subprocess *sp = (Scheme_Subprocess *)argv[0]; #if defined(UNIX_PROCESSES) - { - System_Child *sc = (System_Child *)sp->handle; - - check_child_done(); - - while (1) { - if (sc->done) - return scheme_void; - - if (!kill(sp->pid, SCHEME_TRUEP(argv[1]) ? SIGKILL : SIGINT)) - return scheme_void; - - if (errno != EINTR) - break; - /* Otherwise we were interrupted. Try `kill' again. */ - } +# if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) + { + int status; + if (sp->done) + return scheme_void; + if(scheme_get_child_status(sp->pid, &status)) { + return scheme_void; } + } +# else + { + System_Child *sc = (System_Child *)sp->handle; + + check_child_done(); + if (sc->done) + return scheme_void; + } +# endif + + while (1) { + + if (!kill(sp->pid, SCHEME_TRUEP(argv[1]) ? SIGKILL : SIGINT)) + return scheme_void; + + if (errno != EINTR) + break; + /* Otherwise we were interrupted. Try `kill' again. */ + } #else if (SCHEME_TRUEP(argv[1])) { DWORD w; @@ -7369,6 +7420,16 @@ static long mz_spawnv(char *command, const char * const *argv, static void close_subprocess_handle(void *sp, void *ignored) { Scheme_Subprocess *subproc = (Scheme_Subprocess *)sp; + #if defined(MZ_USE_PLACES) && defined (MZ_PRECISE_GC) + { + int status; + int pid = ((Scheme_Subprocess *)sp)->pid; + scheme_get_child_status(pid, &status) + /* printf("close_subprocess_handle pid %i status %i\n", pid status); */ + + } + #endif + CloseHandle(subproc->handle); } @@ -7387,7 +7448,9 @@ static Scheme_Object *subprocess(int c, Scheme_Object *args[]) char **argv; Scheme_Object *in, *out, *err; #if defined(UNIX_PROCESSES) +# if !(defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)) System_Child *sc; +# endif int fork_errno = 0; #else void *sc = 0; @@ -7609,6 +7672,7 @@ static Scheme_Object *subprocess(int c, Scheme_Object *args[]) /*--------------------------------------*/ { +#if !(defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)) init_sigchld(); sc = MALLOC_ONE_RT(System_Child); @@ -7619,13 +7683,25 @@ static Scheme_Object *subprocess(int c, Scheme_Object *args[]) sc->done = 0; scheme_block_child_signals(1); +#endif pid = fork(); if (pid > 0) { +#if defined(MZ_USE_PLACES) && defined (MZ_PRECISE_GC) + { + int *signal_fd; + int status; + signal_fd = scheme_get_signal_handle(); + scheme_places_register_child(pid, signal_fd, &status); + + /* printf("SUBPROCESS %i\n", pid); */ + } +#else sc->next = scheme_system_children; scheme_system_children = sc; sc->id = pid; +#endif } else if (!pid) { #ifdef USE_ITIMER /* Turn off the timer. */ @@ -7659,7 +7735,9 @@ static Scheme_Object *subprocess(int c, Scheme_Object *args[]) fork_errno = errno; } +#if !(defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)) scheme_block_child_signals(0); +#endif } switch (pid) @@ -7807,7 +7885,9 @@ static Scheme_Object *subprocess(int c, Scheme_Object *args[]) subproc = MALLOC_ONE_TAGGED(Scheme_Subprocess); subproc->so.type = scheme_subprocess_type; +#if !(defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)) subproc->handle = (void *)sc; +#endif subproc->pid = pid; # if defined(WINDOWS_PROCESSES) scheme_add_finalizer(subproc, close_subprocess_handle, NULL); @@ -8781,7 +8861,7 @@ static void register_traversers(void) GC_REG_TRAV(scheme_rt_input_fd, mark_input_fd); #endif -#if defined(UNIX_PROCESSES) +#if defined(UNIX_PROCESSES) && !(defined(MZ_USE_PLACES) && defined (MZ_PRECISE_GC)) GC_REG_TRAV(scheme_rt_system_child, mark_system_child); #endif diff --git a/src/mzscheme/src/print.c b/src/mzscheme/src/print.c index 6a960455ea..5c797bb912 100644 --- a/src/mzscheme/src/print.c +++ b/src/mzscheme/src/print.c @@ -539,6 +539,7 @@ static int check_cycles(Scheme_Object *obj, int for_write, Scheme_Hash_Table *ht version takes to long, we back out to the general case. (We don't even check for stack overflow, so keep the max limit low.) */ +#if !defined(MZ_USE_PLACES) static int check_cycles_fast(Scheme_Object *obj, PrintParams *pp, int *fast_checker_counter) XFORM_SKIP_PROC { @@ -614,6 +615,7 @@ static int check_cycles_fast(Scheme_Object *obj, PrintParams *pp, int *fast_chec return cycle; } +#endif #ifdef DO_STACK_CHECK static void setup_graph_table(Scheme_Object *obj, int for_write, Scheme_Hash_Table *ht, int *counter, PrintParams *pp); diff --git a/src/mzscheme/src/schminc.h b/src/mzscheme/src/schminc.h index 35c3b7afb3..26c15eb7ff 100644 --- a/src/mzscheme/src/schminc.h +++ b/src/mzscheme/src/schminc.h @@ -13,8 +13,8 @@ #define USE_COMPILED_STARTUP 1 -#define EXPECTED_PRIM_COUNT 959 -#define EXPECTED_UNSAFE_COUNT 47 +#define EXPECTED_PRIM_COUNT 965 +#define EXPECTED_UNSAFE_COUNT 52 #ifdef MZSCHEME_SOMETHING_OMITTED # undef USE_COMPILED_STARTUP diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 5c4c3b6989..c8fb71f3ac 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -689,6 +689,8 @@ Scheme_Object *scheme_clone_prefab_struct_instance(Scheme_Structure *s); Scheme_Object *scheme_extract_checked_procedure(int argc, Scheme_Object **argv); +Scheme_Object *scheme_rename_struct_proc(Scheme_Object *p, Scheme_Object *sym); + /*========================================================================*/ /* syntax objects */ /*========================================================================*/ @@ -3190,6 +3192,13 @@ Scheme_Object *scheme_checked_byte_string_ref(int argc, Scheme_Object *argv[]); Scheme_Object *scheme_checked_byte_string_set(int argc, Scheme_Object *argv[]); Scheme_Object *scheme_checked_syntax_e(int argc, Scheme_Object **argv); Scheme_Object *scheme_vector_length(Scheme_Object *v); +Scheme_Object *scheme_checked_flvector_ref(int argc, Scheme_Object **argv); +Scheme_Object *scheme_checked_flvector_set(int argc, Scheme_Object **argv); +Scheme_Object *scheme_flvector_length(Scheme_Object *v); + +void scheme_bad_vec_index(char *name, Scheme_Object *i, + const char *what, Scheme_Object *vec, + long bottom, long len); Scheme_Bucket_Table *scheme_make_weak_equal_table(void); @@ -3248,8 +3257,11 @@ typedef struct Scheme_Symbol_Parts { const char *name; } Scheme_Symbol_Parts; -void spawn_master_scheme_place(); +void scheme_spawn_master_place(); void *scheme_master_fast_path(int msg_type, void *msg_payload); +void scheme_places_block_child_signal(); +int scheme_get_child_status(int pid, int *status); +int scheme_places_register_child(int pid, void *signal_fd, int *status); # endif Scheme_Object *scheme_places_deep_copy(Scheme_Object *so); #endif diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index a7586b1a72..febb42eae0 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "4.2.3.2" +#define MZSCHEME_VERSION "4.2.3.4" #define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_Y 2 #define MZSCHEME_VERSION_Z 3 -#define MZSCHEME_VERSION_W 2 +#define MZSCHEME_VERSION_W 4 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/src/mzscheme/src/string.c b/src/mzscheme/src/string.c index 19a0beaed5..e7bca46d91 100644 --- a/src/mzscheme/src/string.c +++ b/src/mzscheme/src/string.c @@ -2006,7 +2006,7 @@ static void putenv_str_table_put_name(Scheme_Object *name, Scheme_Object *value) void *original_gc; Scheme_Object *name_copy; original_gc = GC_switch_to_master_gc(); - name_copy = (Scheme_Object *) clone_str_with_gc((Scheme_Object *) name); + name_copy = (Scheme_Object *) clone_str_with_gc((const char *) name); create_putenv_str_table_if_needed(); scheme_hash_set(putenv_str_table, name_copy, value); GC_switch_back_from_master(original_gc); @@ -2024,8 +2024,8 @@ static void putenv_str_table_put_name_value(Scheme_Object *name, Scheme_Object * Scheme_Object *name_copy; Scheme_Object *value_copy; original_gc = GC_switch_to_master_gc(); - name_copy = (Scheme_Object *) clone_str_with_gc((Scheme_Object *) name); - value_copy = (Scheme_Object *) clone_str_with_gc((Scheme_Object *) value); + name_copy = (Scheme_Object *) clone_str_with_gc((const char *) name); + value_copy = (Scheme_Object *) clone_str_with_gc((const char *) value); create_putenv_str_table_if_needed(); scheme_hash_set(putenv_str_table, name_copy, value_copy); GC_switch_back_from_master(original_gc); @@ -2054,7 +2054,7 @@ static Scheme_Object *putenv_str_table_get(Scheme_Object *name) { #endif -static Scheme_Object *sch_bool_getenv(const char* name); +static int sch_bool_getenv(const char* name); void scheme_init_getenv(void) @@ -2102,7 +2102,7 @@ scheme_init_getenv(void) # include static char *dos_win_getenv(const char *name) { int value_size; - value_size = GetEnvironmentVariable(s, NULL, 0); + value_size = GetEnvironmentVariable(name, NULL, 0); if (value_size) { char *value; int got; @@ -2112,21 +2112,20 @@ static char *dos_win_getenv(const char *name) { value[got] = 0; return value; } - return name; + return NULL; } #endif -static Scheme_Object *sch_bool_getenv(const char* name) { - Scheme_Object *rc; - rc = scheme_false; +static int sch_bool_getenv(const char* name) { + int rc = 0; #ifdef GETENV_FUNCTION # ifdef DOS_FILE_SYSTEM - if (GetEnvironmentVariable(s, NULL, 0)) rc = scheme_true; + if (GetEnvironmentVariable(name, NULL, 0)) rc = 1; # else - if (getenv(name)) rc = scheme_true; + if (getenv(name)) rc = 1; # endif #else - if (putenv_str_table_get(name)) rc = scheme_true; + if (putenv_str_table_get(name)) rc = 1; #endif return rc; } @@ -2160,6 +2159,7 @@ static Scheme_Object *sch_getenv(int argc, Scheme_Object *argv[]) return value ? scheme_make_locale_string(value) : scheme_false; } +#ifndef DOS_FILE_SYSTEM static int sch_unix_putenv(const char *var, const char *val, const long varlen, const long vallen) { char *buffer; long total_length; @@ -2190,6 +2190,7 @@ static int sch_unix_putenv(const char *var, const char *val, const long varlen, putenv_str_table_put_name((Scheme_Object *)var, (Scheme_Object *)buffer); return putenv(buffer); } +#endif static Scheme_Object *sch_putenv(int argc, Scheme_Object *argv[]) { diff --git a/src/mzscheme/src/struct.c b/src/mzscheme/src/struct.c index 922ee76e37..3499e7c5b6 100644 --- a/src/mzscheme/src/struct.c +++ b/src/mzscheme/src/struct.c @@ -2779,6 +2779,29 @@ make_struct_proc(Scheme_Struct_Type *struct_type, return p; } +Scheme_Object *scheme_rename_struct_proc(Scheme_Object *p, Scheme_Object *sym) +{ + if (SCHEME_PRIMP(p)) { + int is_getter = (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER); + int is_setter = (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER); + + if (is_getter || is_setter) { + const char *func_name; + Struct_Proc_Info *i; + + func_name = scheme_symbol_name(sym); + + i = (Struct_Proc_Info *)SCHEME_PRIM_CLOSURE_ELS(p)[0]; + + return make_struct_proc(i->struct_type, (char *)func_name, + is_getter ? SCHEME_GETTER : SCHEME_SETTER, + i->field); + } + } + + return NULL; +} + static Scheme_Object *make_name(const char *pre, const char *tn, int ltn, const char *post1, const char *fn, int lfn, const char *post2, int sym) diff --git a/src/mzscheme/src/stypes.h b/src/mzscheme/src/stypes.h index ea2d45731e..62ac0382b2 100644 --- a/src/mzscheme/src/stypes.h +++ b/src/mzscheme/src/stypes.h @@ -171,84 +171,85 @@ enum { scheme_noninline_proc_type, /* 153 */ scheme_prune_context_type, /* 154 */ scheme_future_type, /* 155 */ + scheme_flvector_type, /* 156 */ #ifdef MZTAG_REQUIRED - _scheme_last_normal_type_, /* 156 */ + _scheme_last_normal_type_, /* 157 */ - scheme_rt_weak_array, /* 157 */ + scheme_rt_weak_array, /* 158 */ - scheme_rt_comp_env, /* 158 */ - scheme_rt_constant_binding, /* 159 */ - scheme_rt_resolve_info, /* 160 */ - scheme_rt_optimize_info, /* 161 */ - scheme_rt_compile_info, /* 162 */ - scheme_rt_cont_mark, /* 163 */ - scheme_rt_saved_stack, /* 164 */ - scheme_rt_reply_item, /* 165 */ - scheme_rt_closure_info, /* 166 */ - scheme_rt_overflow, /* 167 */ - scheme_rt_overflow_jmp, /* 168 */ - scheme_rt_meta_cont, /* 169 */ - scheme_rt_dyn_wind_cell, /* 170 */ - scheme_rt_dyn_wind_info, /* 171 */ - scheme_rt_dyn_wind, /* 172 */ - scheme_rt_dup_check, /* 173 */ - scheme_rt_thread_memory, /* 174 */ - scheme_rt_input_file, /* 175 */ - scheme_rt_input_fd, /* 176 */ - scheme_rt_oskit_console_input, /* 177 */ - scheme_rt_tested_input_file, /* 178 */ - scheme_rt_tested_output_file, /* 179 */ - scheme_rt_indexed_string, /* 180 */ - scheme_rt_output_file, /* 181 */ - scheme_rt_load_handler_data, /* 182 */ - scheme_rt_pipe, /* 183 */ - scheme_rt_beos_process, /* 184 */ - scheme_rt_system_child, /* 185 */ - scheme_rt_tcp, /* 186 */ - scheme_rt_write_data, /* 187 */ - scheme_rt_tcp_select_info, /* 188 */ - scheme_rt_namespace_option, /* 189 */ - scheme_rt_param_data, /* 190 */ - scheme_rt_will, /* 191 */ - scheme_rt_struct_proc_info, /* 192 */ - scheme_rt_linker_name, /* 193 */ - scheme_rt_param_map, /* 194 */ - scheme_rt_finalization, /* 195 */ - scheme_rt_finalizations, /* 196 */ - scheme_rt_cpp_object, /* 197 */ - scheme_rt_cpp_array_object, /* 198 */ - scheme_rt_stack_object, /* 199 */ - scheme_rt_preallocated_object, /* 200 */ - scheme_thread_hop_type, /* 201 */ - scheme_rt_srcloc, /* 202 */ - scheme_rt_evt, /* 203 */ - scheme_rt_syncing, /* 204 */ - scheme_rt_comp_prefix, /* 205 */ - scheme_rt_user_input, /* 206 */ - scheme_rt_user_output, /* 207 */ - scheme_rt_compact_port, /* 208 */ - scheme_rt_read_special_dw, /* 209 */ - scheme_rt_regwork, /* 210 */ - scheme_rt_buf_holder, /* 211 */ - scheme_rt_parameterization, /* 212 */ - scheme_rt_print_params, /* 213 */ - scheme_rt_read_params, /* 214 */ - scheme_rt_native_code, /* 215 */ - scheme_rt_native_code_plus_case, /* 216 */ - scheme_rt_jitter_data, /* 217 */ - scheme_rt_module_exports, /* 218 */ - scheme_rt_delay_load_info, /* 219 */ - scheme_rt_marshal_info, /* 220 */ - scheme_rt_unmarshal_info, /* 221 */ - scheme_rt_runstack, /* 222 */ - scheme_rt_sfs_info, /* 223 */ - scheme_rt_validate_clearing, /* 224 */ - scheme_rt_rb_node, /* 225 */ + scheme_rt_comp_env, /* 159 */ + scheme_rt_constant_binding, /* 160 */ + scheme_rt_resolve_info, /* 161 */ + scheme_rt_optimize_info, /* 162 */ + scheme_rt_compile_info, /* 163 */ + scheme_rt_cont_mark, /* 164 */ + scheme_rt_saved_stack, /* 165 */ + scheme_rt_reply_item, /* 166 */ + scheme_rt_closure_info, /* 167 */ + scheme_rt_overflow, /* 168 */ + scheme_rt_overflow_jmp, /* 169 */ + scheme_rt_meta_cont, /* 170 */ + scheme_rt_dyn_wind_cell, /* 171 */ + scheme_rt_dyn_wind_info, /* 172 */ + scheme_rt_dyn_wind, /* 173 */ + scheme_rt_dup_check, /* 174 */ + scheme_rt_thread_memory, /* 175 */ + scheme_rt_input_file, /* 176 */ + scheme_rt_input_fd, /* 177 */ + scheme_rt_oskit_console_input, /* 178 */ + scheme_rt_tested_input_file, /* 179 */ + scheme_rt_tested_output_file, /* 180 */ + scheme_rt_indexed_string, /* 181 */ + scheme_rt_output_file, /* 182 */ + scheme_rt_load_handler_data, /* 183 */ + scheme_rt_pipe, /* 184 */ + scheme_rt_beos_process, /* 185 */ + scheme_rt_system_child, /* 186 */ + scheme_rt_tcp, /* 187 */ + scheme_rt_write_data, /* 188 */ + scheme_rt_tcp_select_info, /* 189 */ + scheme_rt_namespace_option, /* 190 */ + scheme_rt_param_data, /* 191 */ + scheme_rt_will, /* 192 */ + scheme_rt_struct_proc_info, /* 193 */ + scheme_rt_linker_name, /* 194 */ + scheme_rt_param_map, /* 195 */ + scheme_rt_finalization, /* 196 */ + scheme_rt_finalizations, /* 197 */ + scheme_rt_cpp_object, /* 198 */ + scheme_rt_cpp_array_object, /* 199 */ + scheme_rt_stack_object, /* 200 */ + scheme_rt_preallocated_object, /* 201 */ + scheme_thread_hop_type, /* 202 */ + scheme_rt_srcloc, /* 203 */ + scheme_rt_evt, /* 204 */ + scheme_rt_syncing, /* 205 */ + scheme_rt_comp_prefix, /* 206 */ + scheme_rt_user_input, /* 207 */ + scheme_rt_user_output, /* 208 */ + scheme_rt_compact_port, /* 209 */ + scheme_rt_read_special_dw, /* 210 */ + scheme_rt_regwork, /* 211 */ + scheme_rt_buf_holder, /* 212 */ + scheme_rt_parameterization, /* 213 */ + scheme_rt_print_params, /* 214 */ + scheme_rt_read_params, /* 215 */ + scheme_rt_native_code, /* 216 */ + scheme_rt_native_code_plus_case, /* 217 */ + scheme_rt_jitter_data, /* 218 */ + scheme_rt_module_exports, /* 219 */ + scheme_rt_delay_load_info, /* 220 */ + scheme_rt_marshal_info, /* 221 */ + scheme_rt_unmarshal_info, /* 222 */ + scheme_rt_runstack, /* 223 */ + scheme_rt_sfs_info, /* 224 */ + scheme_rt_validate_clearing, /* 225 */ + scheme_rt_rb_node, /* 226 */ #endif - scheme_place_type, /* 226 */ - scheme_engine_type, /* 227 */ + scheme_place_type, /* 227 */ + scheme_engine_type, /* 228 */ _scheme_last_type_ }; diff --git a/src/mzscheme/src/thread.c b/src/mzscheme/src/thread.c index 86995727bc..33341d05b8 100644 --- a/src/mzscheme/src/thread.c +++ b/src/mzscheme/src/thread.c @@ -4057,7 +4057,7 @@ void scheme_thread_block(float sleep_time) /* Check scheduled_kills early and often. */ check_scheduled_kills(); -#ifdef UNIX_PROCESSES +#if defined(UNIX_PROCESSES) && !(defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)) /* Reap zombie processes: */ scheme_check_child_done(); #endif @@ -4142,6 +4142,10 @@ void scheme_thread_block(float sleep_time) } #endif +/*####################################*/ +/* THREAD CONTEXT SWITCH HAPPENS HERE */ +/*####################################*/ + if (next) { /* Swap in `next', but first clear references to other threads. */ swap_target = next; @@ -4188,6 +4192,11 @@ void scheme_thread_block(float sleep_time) if (p->external_break && !p->suspend_break && scheme_can_break(p)) { raise_break(p); } + + /* Check for major GC request from master GC */ +#if defined(MZ_PRECISE_GC) && defined(MZ_USE_PLACES) + GC_check_master_gc_request(); +#endif if (sleep_end > 0) { if (sleep_end > scheme_get_inexact_milliseconds()) { @@ -7362,7 +7371,7 @@ static void get_ready_for_GC() #ifdef WINDOWS_PROCESSES scheme_suspend_remembered_threads(); #endif -#ifdef UNIX_PROCESSES +#if defined(UNIX_PROCESSES) && !(defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)) scheme_block_child_signals(1); #endif @@ -7393,7 +7402,7 @@ static void done_with_GC() #ifdef WINDOWS_PROCESSES scheme_resume_remembered_threads(); #endif -#ifdef UNIX_PROCESSES +#if defined(UNIX_PROCESSES) && !(defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)) scheme_block_child_signals(0); #endif diff --git a/src/mzscheme/src/type.c b/src/mzscheme/src/type.c index 297e0ab71f..5408530458 100644 --- a/src/mzscheme/src/type.c +++ b/src/mzscheme/src/type.c @@ -161,6 +161,7 @@ scheme_init_type () set_name(scheme_syntax_compiler_type, ""); set_name(scheme_macro_type, ""); set_name(scheme_vector_type, ""); + set_name(scheme_flvector_type, ""); set_name(scheme_bignum_type, ""); set_name(scheme_escaping_cont_type, ""); set_name(scheme_sema_type, ""); @@ -540,6 +541,7 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_mutable_pair_type, cons_cell); GC_REG_TRAV(scheme_raw_pair_type, cons_cell); GC_REG_TRAV(scheme_vector_type, vector_obj); + GC_REG_TRAV(scheme_flvector_type, flvector_obj); GC_REG_TRAV(scheme_cpointer_type, cpointer_obj); GC_REG_TRAV(scheme_offset_cpointer_type, offset_cpointer_obj); diff --git a/src/mzscheme/src/vector.c b/src/mzscheme/src/vector.c index 3a3d661da4..2818ebdcb2 100644 --- a/src/mzscheme/src/vector.c +++ b/src/mzscheme/src/vector.c @@ -321,27 +321,33 @@ Scheme_Object *scheme_vector_length(Scheme_Object *v) return vector_length(1, a); } -static Scheme_Object * -bad_index(char *name, Scheme_Object *i, Scheme_Object *vec, int bottom) +void scheme_bad_vec_index(char *name, Scheme_Object *i, const char *what, Scheme_Object *vec, + long bottom, long len) { - int n = SCHEME_VEC_SIZE(vec) - 1; - - if (SCHEME_VEC_SIZE(vec)) { + if (len) { + long n = len - 1; char *vstr; int vlen; vstr = scheme_make_provided_string(vec, 2, &vlen); scheme_raise_exn(MZEXN_FAIL_CONTRACT, - "%s: index %s out of range [%d, %d] for vector: %t", + "%s: index %s out of range [%ld, %ld] for %s: %t", name, scheme_make_provided_string(i, 2, NULL), bottom, n, + what, vstr, vlen); } else scheme_raise_exn(MZEXN_FAIL_CONTRACT, - "%s: bad index %s for empty vector", + "%s: bad index %s for empty %s", name, - scheme_make_provided_string(i, 0, NULL)); - + scheme_make_provided_string(i, 0, NULL), + what); +} + +static Scheme_Object * +bad_index(char *name, Scheme_Object *i, Scheme_Object *vec, int bottom) +{ + scheme_bad_vec_index(name, i, "vector", vec, bottom, SCHEME_VEC_SIZE(vec)); return NULL; } diff --git a/src/worksp/mred/mred.manifest b/src/worksp/mred/mred.manifest index 7b98bfb05e..a9be731446 100644 --- a/src/worksp/mred/mred.manifest +++ b/src/worksp/mred/mred.manifest @@ -1,7 +1,7 @@