diff --git a/collects/2htdp/private/image-more.ss b/collects/2htdp/private/image-more.ss index 4af533fb28..5068aa47e4 100644 --- a/collects/2htdp/private/image-more.ss +++ b/collects/2htdp/private/image-more.ss @@ -2,6 +2,7 @@ (require "../../mrlib/image-core.ss" "img-err.ss" + scheme/match scheme/contract scheme/class scheme/gui/base @@ -117,7 +118,7 @@ (overlay/internal 'middle 'middle image (cons image2 image3))) ;; underlay : image image image ... -> image -(define (underlay image image2 . image3) +(define/chk (underlay image image2 . image3) (let ([imgs (reverse (list* image image2 image3))]) (overlay/internal 'middle 'middle (car imgs) (cdr imgs)))) @@ -279,9 +280,10 @@ (crop/internal x1 y1 width height image)) (define (crop/internal x1 y1 width height image) - (let ([iw (min width (get-right image))] - [ih (min height (get-bottom image))]) - (make-image (make-crop (rectangle-points iw ih) + (let* ([iw (min width (get-right image))] + [ih (min height (get-bottom image))] + [points (rectangle-points iw ih)]) + (make-image (make-crop points (make-translate (- x1) (- y1) (image-shape image))) (make-bb iw ih @@ -363,26 +365,28 @@ (- (ltrb-bottom ltrb) (ltrb-top ltrb))) #f))) -(define (rotate-normalized-shape angle shape) +(define/contract (rotate-normalized-shape angle shape) + (-> number? normalized-shape? normalized-shape?) (cond [(overlay? shape) (let ([top-shape (rotate-normalized-shape angle (overlay-top shape))] - [bottom-shape (rotate-simple angle (overlay-bottom shape))]) + [bottom-shape (rotate-cn-or-simple-shape angle (overlay-bottom shape))]) (make-overlay top-shape bottom-shape))] [else - (rotate-cropped-simple angle shape)])) + (rotate-cn-or-simple-shape angle shape)])) -;; rotate-cropped-simple : angle cropped-simple-shape -> cropped-simple-shape -(define (rotate-cropped-simple angle shape) +(define/contract (rotate-cn-or-simple-shape angle shape) + (-> number? cn-or-simple-shape? cn-or-simple-shape?) (cond [(crop? shape) (make-crop (rotate-points angle (crop-points shape)) - (rotate-cropped-simple angle (crop-shape shape)))] - [else + (rotate-normalized-shape angle (crop-shape shape)))] + [else (rotate-simple angle shape)])) ;; rotate-simple : angle simple-shape -> simple-shape (define (rotate-simple θ simple-shape) + (-> number? simple-shape? simple-shape?) (cond [(line-segment? simple-shape) (make-line-segment (rotate-point (line-segment-start simple-shape) @@ -425,21 +429,21 @@ (min (ltrb-right ltrb1) (ltrb-right ltrb2)) (min (ltrb-bottom ltrb1) (ltrb-bottom ltrb2)))) -;; normalized-shape-bb : normalized-shape -> ltrb -(define (normalized-shape-bb shape) +(define/contract (normalized-shape-bb shape) + (-> normalized-shape? ltrb?) (cond [(overlay? shape) (let ([top-ltrb (normalized-shape-bb (overlay-top shape))] - [bottom-ltrb (simple-bb (overlay-bottom shape))]) + [bottom-ltrb (cn-or-simple-shape-bb (overlay-bottom shape))]) (union-ltrb top-ltrb bottom-ltrb))] [else - (cropped-simple-bb shape)])) + (cn-or-simple-shape-bb shape)])) -;; cropped-simple-bb : cropped-simple-shape -> ltrb -(define (cropped-simple-bb shape) +(define/contract (cn-or-simple-shape-bb shape) + (-> cn-or-simple-shape? ltrb?) (cond [(crop? shape) - (let ([ltrb (cropped-simple-bb (crop-shape shape))] + (let ([ltrb (normalized-shape-bb (crop-shape shape))] [crop-ltrb (points->ltrb (crop-points shape))]) (intersect-ltrb crop-ltrb ltrb))] [else @@ -448,7 +452,8 @@ ;; simple-bb : simple-shape -> ltrb ;; returns the bounding box of 'shape' ;; (only called for rotated shapes, so bottom=baseline) -(define (simple-bb simple-shape) +(define/contract (simple-bb simple-shape) + (-> simple-shape? ltrb?) (cond [(line-segment? simple-shape) (let ([x1 (point-x (line-segment-start simple-shape))] @@ -484,6 +489,7 @@ (make-ltrb left top right bottom))) (define (np-atomic-bb atomic-shape) + (-> np-atomic-shape? (values number? number? number? number?)) (cond [(ellipse? atomic-shape) (let ([θ (ellipse-angle atomic-shape)]) @@ -554,6 +560,7 @@ ;; rotate-atomic : angle np-atomic-shape -> np-atomic-shape (define (rotate-atomic θ atomic-shape) + (-> number? np-atomic-shape? np-atomic-shape?) (cond [(ellipse? atomic-shape) (cond diff --git a/collects/2htdp/private/img-err.ss b/collects/2htdp/private/img-err.ss index 2b072c8ac7..78ed2ca40e 100644 --- a/collects/2htdp/private/img-err.ss +++ b/collects/2htdp/private/img-err.ss @@ -49,7 +49,7 @@ [(define/chk (fn-name args ... . final-arg) body ...) (identifier? #'final-arg) (let ([len (length (syntax->list #'(args ...)))]) - (with-syntax ([(i ...) (build-list len values)]) + (with-syntax ([(i ...) (build-list len add1)]) #`(define (fn-name args ... . final-arg) (let ([args (check/normalize 'fn-name 'args args i)] ... [final-arg (map/i (λ (x j) (check/normalize 'fn-name 'final-arg x (+ #,len j))) diff --git a/collects/2htdp/tests/image-equality-performance.ss b/collects/2htdp/tests/image-equality-performance.ss new file mode 100644 index 0000000000..79960d210e --- /dev/null +++ b/collects/2htdp/tests/image-equality-performance.ss @@ -0,0 +1,908 @@ +#lang scheme + +#| + +This is a file from Guillaume that ran very slowly with the +htdp/image library; here it is used as a performance test. +Porting to #lang scheme +2htdp/image consisted of adding requires, +changing overlay/xy to underlay/xy, defining empty-scene, and +adding the check-expect macro (and related code). +Also added the timing code at the end. + +|# + + +(require 2htdp/image + (only-in mrlib/image-core + skip-image-equality-fast-path)) + +(define-syntax (check-expect stx) + (syntax-case stx () + [(_ a b) + (with-syntax ([line (syntax-line stx)]) + #'(set! tests (cons (list (λ () a) (λ () b) line) + tests)))])) +(define tests '()) +(define (run-tests) + (for-each + (λ (l) + (let ([a-res ((list-ref l 0))] + [b-res ((list-ref l 1))] + [line (list-ref l 2)]) + (unless (equal? a-res b-res) + (error 'test "test failed; expected ~s and ~s to be equal, but they weren't, line ~a" + a-res + b-res + line)))) + tests)) + +(define (empty-scene w h) + (overlay + (rectangle w h 'solid 'white) + (rectangle w h 'outline 'black))) + +;;Program for creating game of croos-circle game +;;contract :image->image + +;;defining a union square +;;A square is either +;;A square is blank +;;A square is cross +;;A square is Circle + +;;defining width of square +(define square-width 150) + +;;defining th height and width of scene +(define width (* square-width 3)) +(define height (* square-width 3)) + + +;;defining the image circle +(define Circle (underlay/xy (circle 20 'solid 'orange) 0 0 (circle 10 'solid 'white))) +;;defining the image cross +(define cross (underlay/xy (rectangle 10 30 'solid 'green) 0 0 (rectangle 30 10 'solid 'green))) +;;defining the blank image +(define blank (underlay/xy (rectangle square-width square-width 'solid 'red) 0 0 + (rectangle (- square-width 8) (- square-width 8) 'solid 'white))) + +;;Given a square returns +;;the image of square +;;draw-square :square ->image +(define (draw-square square) + (cond[(equal? 'Circle square)(underlay/xy blank 0 0 Circle)] + [(equal? 'cross square)(underlay/xy blank 0 0 cross)] + [(equal? 'blank square)blank] + )) + + +;;test +(check-expect(draw-square 'Circle)(underlay/xy blank 0 0 Circle)) +(check-expect(draw-square 'cross)(underlay/xy blank 0 0 cross)) +(check-expect(draw-square 'blank)blank) + +;;== Cross and circles, part #3 == + + +;;define a structure for ROW +;;ROW structure used for creating a ROW in the board +;;contract ROW:image image image->image +(define-struct ROW (left middle right) #:transparent) + + +;; defining a blank row + +(define blank-ROW (make-ROW 'blank 'blank 'blank)) +;;defining the cross row +(define cross-ROW (make-ROW 'blank 'cross 'blank)) + +;;defineing the cross-row-blank secoend combination +(define cross-ROW-blank (make-ROW 'cross 'cross 'blank )) +;;defining a row cross-row +(define cross-row (make-ROW 'cross 'cross 'cross )) +;;defining a row blank-circle +(define blank-circle (make-ROW 'Circle 'blank 'blank)) +;;defining a row cross-circle +(define cross-circle (make-ROW 'cross 'cross 'Circle )) +;;defining a row circle-cross +(define circle-cross (make-ROW 'cross 'Circle 'Circle )) +;;defining a row cross-blank +(define cross-blank (make-ROW 'cross 'blank 'blank )) +;;function for creating ROW with the square +;;contract:square square square->ROW +;template: for draw-row +;template for ROW +;(define (a-row-function a-row) +; ... (row-left a-row) ;; is a square +; ... (row-mid a-row) ;; is a square +; ... (row-right a-row)) ;; is a square + + + +(define (draw-row row) + (underlay/xy (draw-square(ROW-left row)) (image-width blank) 0 + (underlay/xy (draw-square(ROW-middle row)) (image-width blank) 0 (draw-square(ROW-right row)) ))) + +;;test + +(check-expect (draw-row (make-ROW 'Circle 'cross 'blank)) + (underlay/xy (draw-square 'Circle) (image-width blank) 0 + (underlay/xy (draw-square 'cross ) (image-width blank) 0 (draw-square 'blank) ))) + +(check-expect (draw-row (make-ROW 'Circle 'cross 'blank)) + (underlay/xy (draw-square 'Circle) (image-width blank) 0 + (underlay/xy (draw-square 'cross ) (image-width blank) 0 (draw-square 'blank) ))) + +(check-expect (draw-row (make-ROW 'Circle 'blank 'cross)) + (underlay/xy (draw-square 'Circle) (image-width blank) 0 + (underlay/xy (draw-square 'blank ) (image-width blank) 0 (draw-square 'cross) ))) + +(check-expect (draw-row cross-ROW-blank) + (underlay/xy (draw-square 'cross) (image-width blank) 0 + (underlay/xy (draw-square 'cross ) (image-width blank) 0 (draw-square 'blank) ))) + +(check-expect (draw-row cross-row ) + (underlay/xy (draw-square 'cross) (image-width blank) 0 + (underlay/xy (draw-square 'cross ) (image-width blank) 0 (draw-square 'cross) ))) + +;;define a structure for BOARD +;;contract make-BOARD :image image image->image +(define-struct BOARD (top-row center-row bottom-row) #:transparent) + +;; purpose : defining an empty board +(define empty-board (make-BOARD blank-ROW + blank-ROW + blank-ROW)) + +;;function for creating board with the row + +;template: for draw-board +;(define (a-board-function a-row) +; ... (top-row a-row) ;; is a square +; ... (center-row a-row) ;; is a square +; ... (bottom-row a-row)) ;; is a square + +;;defining the background +(define background (empty-scene width height)) + + +;;this function will reusing the fuction draw-row for creating row +;;contract:row row row->board + +;;test +(check-expect (draw-board (make-BOARD cross-ROW-blank + cross-ROW + cross-row )) + (underlay/xy (draw-row cross-ROW-blank) + 0 (image-height (draw-row cross-ROW)) + (underlay/xy (draw-row cross-ROW) + 0 (image-height (draw-row cross-ROW)) + (draw-row cross-row )))) + +(check-expect (draw-board (make-BOARD cross-circle + (make-ROW 'Circle 'cross 'blank) + circle-cross)) + (underlay/xy (draw-row cross-circle) + 0 (image-height (draw-row cross-circle)) + (underlay/xy (draw-row (make-ROW 'Circle 'cross 'blank)) + 0 (image-height (draw-row(make-ROW 'Circle 'cross 'blank))) + (draw-row circle-cross)))) + +(check-expect(draw-board (make-BOARD cross-circle + (make-ROW 'Circle 'cross 'Circle) + circle-cross)) + (underlay/xy (draw-row cross-circle) + 0 (image-height (draw-row cross-circle)) + (underlay/xy (draw-row (make-ROW 'Circle 'cross 'Circle)) + 0 (image-height (draw-row (make-ROW 'Circle 'cross 'Circle))) + (draw-row circle-cross)))) + +(check-expect (draw-board (make-BOARD (make-ROW 'blank 'cross 'Circle) + (make-ROW 'Circle 'cross 'cross) + circle-cross)) + (underlay/xy (draw-row (make-ROW 'blank 'cross 'Circle)) + 0 (image-height (draw-row (make-ROW 'blank 'cross 'Circle))) + (underlay/xy (draw-row (make-ROW 'Circle 'cross 'cross)) + 0 (image-height (draw-row (make-ROW 'Circle 'cross 'cross))) + (draw-row circle-cross))) ) + +(check-expect (draw-board (make-BOARD (make-ROW 'blank 'cross 'Circle) + (make-ROW 'Circle 'blank 'cross) + (make-ROW 'cross 'blank 'Circle))) + (underlay/xy (draw-row (make-ROW 'blank 'cross 'Circle)) + 0 (image-height (draw-row (make-ROW 'blank 'cross 'Circle))) + (underlay/xy (draw-row (make-ROW 'Circle 'blank 'cross)) + 0 (image-height (draw-row (make-ROW 'Circle 'blank 'cross))) + (draw-row (make-ROW 'cross 'blank 'Circle))))) + + + + +(define (draw-board board) + (underlay/xy (draw-row (BOARD-top-row board)) + 0 (image-height (draw-row (BOARD-top-row board))) + (underlay/xy (draw-row (BOARD-center-row board)) + 0 (image-height (draw-row(BOARD-center-row board))) + (draw-row (BOARD-bottom-row board))))) + +;;purpose: given the x coordinate of the mouse click and returns +;;the symbol 'L, the symbol 'M, or the symbol 'R, +;;depending on whether that X position falls on the right, the middle or the left of the board. +;;contract: which-column:: number -> symbol + +;;test + +(check-expect (which-column (* square-width .5)) 'L) +(check-expect (which-column (* square-width 1.5)) 'M) +(check-expect (which-column (* square-width 2.3)) 'R) + +(define (which-column x-pos) + (cond[(and (>= x-pos 0)(<= x-pos square-width))'L] + [(and (>= x-pos (+ square-width 1))(<= x-pos (* 2 square-width)))'M] + [(and (>= x-pos (+ (* 2 square-width) 1))(<= x-pos (* 3 square-width)))'R] + [else "play in the board,you played outside the square"])) + + + +;;purpose: given the y coordinate of the mouse click and returns +;;the symbol 'T, the symbol 'C, or the symbol 'B, +;;depending on whether that Y position falls on the top, the center or the bottom of the board. +;;contract: which-row:: number -> symbol + +;;test + +(check-expect (which-row (* square-width .6)) 'T) +(check-expect (which-row (* square-width 1.3)) 'C) +(check-expect (which-row (* square-width 2.7)) 'B) + +(define (which-row y-pos) + (cond[(and (>= y-pos 0)(<= y-pos square-width))'T] + [(and (>= y-pos (+ square-width 1))(<= y-pos (* 2 square-width)))'C] + [(and (>= y-pos (+ (* 2 square-width) 1))(<= y-pos (* 3 square-width)))'B] + [else "play in the board,you played outside the square"])) + + + +;;purpose: give the row and the square to be played and returns a new row replacing the left square +;; play-on-left : row square ->row + +;;test +(check-expect (play-on-left (make-ROW 'blank 'cross 'Circle) 'Circle) + (make-ROW 'Circle 'cross 'Circle)) + +(check-expect (play-on-left (make-ROW 'blank 'cross 'Circle) 'cross) + cross-circle) + +(check-expect (play-on-left cross-ROW 'Circle) + (make-ROW 'Circle 'cross 'blank)) +(define (play-on-left row play) + (make-ROW play (ROW-middle row) (ROW-right row))) + + +;;purpose: give the row and the square to be played and returns a new row replacing the middle square +;; play-on-middle : row square ->row + +;;test +(check-expect (play-on-middle (make-ROW 'blank 'blank 'Circle) 'Circle) + (make-ROW 'blank 'Circle 'Circle)) + +(check-expect (play-on-middle (make-ROW 'blank 'blank 'Circle) 'cross) + (make-ROW 'blank 'cross 'Circle)) + +(check-expect (play-on-middle blank-ROW 'Circle) + (make-ROW 'blank 'Circle 'blank)) + +(define (play-on-middle row play) + (make-ROW (ROW-left row) play (ROW-right row))) + + +;;purpose: give the row and the square to be played and returns a new row replacing the right square +;; play-on-right : row square ->row + +;;test +(check-expect (play-on-right blank-ROW 'Circle) + (make-ROW 'blank 'blank 'Circle)) + +(check-expect (play-on-right (make-ROW 'blank 'Circle 'blank) 'cross) + (make-ROW 'blank 'Circle 'cross)) + +(check-expect (play-on-right blank-ROW 'Circle) + (make-ROW 'blank 'blank 'Circle)) + +(define (play-on-right row play) + (make-ROW (ROW-left row) (ROW-middle row) play )) + +;;purpose : given the row, which column ,square to be played returns new row replacing the column +;; play-on-row : row square symbol -> row + +(check-expect (play-on-row blank-ROW 'L 'Circle) + (make-ROW 'Circle 'blank 'blank)) +(check-expect (play-on-row blank-ROW 'M 'Circle) + (make-ROW 'blank 'Circle 'blank)) +(check-expect (play-on-row blank-ROW 'R 'Circle) + (make-ROW 'blank 'blank 'Circle)) + +(define (play-on-row row column-label play) + (cond [(equal? column-label 'L) (make-ROW play (ROW-middle row) (ROW-right row))] + [(equal? column-label 'M) (make-ROW (ROW-left row) play (ROW-right row))] + [(equal? column-label 'R) (make-ROW (ROW-left row) (ROW-middle row) play)] + [else row])) + +;;purpose given a board, a square to be played and the label of the position to be played +;;returns a new board with the square to be played at the labeled position on the top row + +;; play-on-board-at-top : board square symbol -> board +;;test +(check-expect (play-on-board-at-top empty-board 'Circle 'L) + (make-BOARD (make-ROW 'Circle 'blank 'blank) + blank-ROW + blank-ROW)) + + +(check-expect (play-on-board-at-top empty-board 'Circle 'M) + (make-BOARD (make-ROW 'blank 'Circle 'blank) + blank-ROW + blank-ROW)) + + +(check-expect (play-on-board-at-top empty-board 'cross 'R) + (make-BOARD (make-ROW 'blank 'blank 'cross) + blank-ROW + blank-ROW)) + + +(define (play-on-board-at-top board play column-label) + (make-BOARD(play-on-row (BOARD-top-row board) column-label play) + (BOARD-center-row board)(BOARD-bottom-row board)) + ) + + + +;;purpose given a board, a square to be played and the label of the position to be played +;;returns a new board with the square to be played at the labeled position on the middle row + +;; play-on-board-at-top : board square symbol -> board +;;test +(check-expect (play-on-board-at-middle empty-board 'Circle 'L) + (make-BOARD blank-ROW + (make-ROW 'Circle 'blank 'blank) + blank-ROW)) + + +(check-expect (play-on-board-at-middle empty-board 'Circle 'M) + (make-BOARD blank-ROW + (make-ROW 'blank 'Circle 'blank) + blank-ROW)) + + +(check-expect (play-on-board-at-middle empty-board 'cross 'R) + (make-BOARD blank-ROW + (make-ROW 'blank 'blank 'cross) + blank-ROW)) + + +(define (play-on-board-at-middle board play column-label) + (make-BOARD (BOARD-top-row board) (play-on-row (BOARD-center-row board) column-label play) + (BOARD-bottom-row board)) + ) +;;purpose given a board, a square to be played and the label of the position to be played +;;returns a new board with the square to be played at the labeled position on the bottom row + +;; play-on-board-at-top : board square symbol -> board +;;test +(check-expect (play-on-board-at-bottom empty-board 'Circle 'L) + (make-BOARD blank-ROW + blank-ROW + (make-ROW 'Circle 'blank 'blank))) + + +(check-expect (play-on-board-at-bottom empty-board 'Circle 'M) + (make-BOARD blank-ROW + blank-ROW + (make-ROW 'blank 'Circle 'blank))) + + +(check-expect (play-on-board-at-bottom empty-board 'cross 'R) + (make-BOARD blank-ROW + blank-ROW + (make-ROW 'blank 'blank 'cross))) + + +(define (play-on-board-at-bottom board play column-label) + (make-BOARD (BOARD-top-row board) (BOARD-center-row board) + (play-on-row (BOARD-bottom-row board) column-label play) + ) + ) + + +;;purpose :given the board ,square to be played,column and row label and returns a new board +;;with the square to be played at the position reffered +;; play-on-board : board square symbol symbol -> board + +;;test +(check-expect (play-on-board empty-board 'cross 'R 'T) + (make-BOARD (make-ROW 'blank 'blank 'cross ) + blank-ROW + blank-ROW)) + + +(check-expect (play-on-board empty-board 'cross 'L 'C) + (make-BOARD blank-ROW + cross-blank + blank-ROW)) + + +(check-expect (play-on-board empty-board 'cross 'M 'B) + (make-BOARD blank-ROW + blank-ROW + cross-ROW)) + + +(define (play-on-board board play column-label row-label) + (cond [(equal? row-label 'T) (play-on-board-at-top board play column-label)] + [(equal? row-label 'C) (play-on-board-at-middle board play column-label)] + [(equal? row-label 'B) (play-on-board-at-bottom board play column-label)] + [else board])) + + +;;purpose : Given a board structure, a return the image of that board centered on the scene. +;;create-board:board->scene + +;;test +(check-expect (create-board (make-BOARD blank-ROW + blank-ROW + cross-ROW)) + (place-image (draw-board (make-BOARD blank-ROW + blank-ROW + cross-ROW)) + (/ square-width 2)(/ square-width 2) background)) + +(check-expect (create-board (make-BOARD (make-ROW 'Circle 'cross 'Circle) + blank-ROW + cross-ROW)) + (place-image (draw-board (make-BOARD (make-ROW 'Circle 'cross 'Circle) + blank-ROW + cross-ROW)) + (/ square-width 2)(/ square-width 2) background)) + +(check-expect (create-board (make-BOARD (make-ROW 'Circle 'cross 'blank) + blank-ROW + cross-ROW)) + (place-image (draw-board (make-BOARD (make-ROW 'Circle 'cross 'blank) + blank-ROW + cross-ROW)) + (/ square-width 2)(/ square-width 2) background)) + +(define (create-board board) + (place-image (draw-board board)(/ square-width 2)(/ square-width 2) background) + ) + +;; clack1 : Mouse handler. Plays a cross (always a cross) where the mouse is clicked, on button-up. +;; clack1 : board number number symbol -> board + +(define (clack1 board x y event) + (cond [(symbol=? event 'button-up) + (play-on-board board 'cross (which-column x) (which-row y))] + [else board])) + +(check-expect (clack1 (make-BOARD blank-ROW + blank-ROW + cross-ROW) 40 68 'button-up) + (make-BOARD cross-blank + blank-ROW + cross-ROW)) + +(check-expect (clack1 (make-BOARD blank-ROW + blank-ROW + cross-ROW) 160 168 'button-up) + (make-BOARD blank-ROW + (make-ROW 'blank 'cross 'blank) + cross-ROW)) + +(check-expect (clack1 (make-BOARD blank-ROW + blank-ROW + blank-ROW) 310 365 'button-up) + (make-BOARD blank-ROW + blank-ROW + (make-ROW 'blank 'blank 'cross) + )) +;; purpose : Given the current player, return which player goes next. +;; other-player : square -> square + +(define (other-player play) + (cond [(equal? play 'Circle) 'cross] + [(equal? play 'cross) 'Circle])) + +(check-expect (other-player 'cross) 'Circle) +(check-expect (other-player 'Circle) 'cross) + +;; purpose : Given a horz. pos (either 'L, 'M or 'R), finds the content of that square. +;; lookup-square : row symbol -> square + +(define (lookup-square column-label row) + (cond [(equal? column-label 'L)(ROW-left row)] + [(equal? column-label 'M)(ROW-middle row)] + [(equal? column-label 'R)(ROW-right row)])) + +(check-expect(lookup-square 'L (make-ROW 'blank 'Circle 'cross)) 'blank) +(check-expect(lookup-square 'M (make-ROW 'blank 'Circle 'cross)) 'Circle) +(check-expect(lookup-square 'R (make-ROW 'blank 'Circle 'cross)) 'cross) + +;; lookup-row : Given a vert. pos (either 'T, 'C or 'B), finds that row. +;; lookup-row : board symbol -> row + +(define(lookup-row row-label board) + (cond [(equal? row-label 'T)(BOARD-top-row board)] + [(equal? row-label 'C)(BOARD-center-row board)] + [(equal? row-label 'B)(BOARD-bottom-row board)])) + + +(check-expect(lookup-row 'T (make-BOARD (make-ROW 'cross 'blank 'Circle) + blank-ROW + blank-ROW)) (make-ROW 'cross 'blank 'Circle)) + +(check-expect(lookup-row 'C (make-BOARD blank-ROW + (make-ROW 'cross 'blank 'Circle) + blank-ROW)) (make-ROW 'cross 'blank 'Circle)) + +(check-expect(lookup-row 'B (make-BOARD blank-ROW + blank-ROW + (make-ROW 'cross 'blank 'Circle) + )) (make-ROW 'cross 'blank 'Circle)) + +;; lookup : Given a horz. and a vert. pos, finds that square. +;; lookup : board symbol symbol -> square + +(define (lookup board column-label row-label) + (lookup-square column-label (lookup-row row-label board))) + +(check-expect(lookup(make-BOARD (make-ROW 'cross 'blank 'Circle) + blank-ROW + blank-ROW) 'L 'T) 'cross) + +(check-expect(lookup(make-BOARD blank-ROW + (make-ROW 'cross 'blank 'Circle) + blank-ROW) 'M 'C) 'blank) + +(check-expect(lookup(make-BOARD blank-ROW + blank-ROW + (make-ROW 'cross 'blank 'Circle) + ) 'R 'B) 'Circle) + + +;; move-legal? : Return true if the square at horizondal and vertical position is blank. +;; move-legal? : board symbol symbol -> boolean + +(define(move-legal? board column-label row-label) + (equal? (lookup board column-label row-label) 'blank)) + +(check-expect (move-legal? empty-board 'L 'C) true) +(check-expect (move-legal? (make-BOARD blank-ROW + (make-ROW 'Circle 'cross cross) + blank-ROW) + 'M 'C) false) +;;define a structure for game +;;contract make-game :square board number->game +(define-struct GAME (next-player board move-count) #:transparent) + +;;defining the initial-game +(define initial-game (make-GAME 'cross empty-board 0)) + +;;purpose: Given a game and a horz. and vert. position, the next player plays in that square, if legal. The move-count goes up by 1,and the next-player switches hand. +;; play-on-game : game symbol symbol -> game + +(check-expect(play-on-game initial-game 'L 'T) + (make-GAME 'Circle + (make-BOARD cross-blank blank-ROW blank-ROW) 1)) + +(check-expect(play-on-game (make-GAME 'Circle + (make-BOARD cross-blank blank-ROW blank-ROW) 1) + 'M 'C ) + (make-GAME 'cross + (make-BOARD cross-blank + (make-ROW 'blank 'Circle 'blank) + blank-ROW) 2)) +(check-expect(play-on-game(make-GAME 'cross + (make-BOARD cross-blank + (make-ROW 'blank 'Circle 'blank) + blank-ROW) 2) + 'R 'B) + (make-GAME 'Circle + (make-BOARD cross-blank + (make-ROW 'blank 'Circle 'blank) + (make-ROW 'blank 'blank 'cross)) 3)) + +(define (play-on-game game column-label row-label) + (cond [ (move-legal? (GAME-board game) column-label row-label) + (make-GAME (other-player (GAME-next-player game)) + (play-on-board (GAME-board game) (GAME-next-player game) column-label row-label) + (+ (GAME-move-count game) 1))] + [else game])) + +;; game-over? : Returns true when the game is over. +;; game-over? : game -> boolean +(check-expect (game-over? (make-GAME 'Circle (make-BOARD cross-blank + (make-ROW 'blank 'Circle 'blank) + (make-ROW 'blank 'blank 'cross))3)) false) +(check-expect (game-over? (make-GAME 'Circle (make-BOARD cross-ROW-blank + (make-ROW 'blank 'Circle 'blank) + (make-ROW 'blank 'blank 'cross))3)) false) +(check-expect (game-over? (make-GAME 'Circle (make-BOARD cross-circle + (make-ROW 'cross 'Circle 'cross) + (make-ROW 'Circle 'cross 'Circle))9))true) +(define (game-over? game) + (>= (GAME-move-count game) 9)) + + + +;; clack2 : Mouse handler. Plays the game on button-up. +;; clack2 : game number number symbol -> game + +(check-expect (clack2 initial-game 90 90 'button-up) + (make-GAME 'Circle + (make-BOARD cross-blank blank-ROW blank-ROW) 1)) + +(check-expect (clack2 (make-GAME 'Circle + (make-BOARD cross-blank blank-ROW blank-ROW) 1) + 160 160 'button-up) + (make-GAME 'cross + (make-BOARD cross-blank + (make-ROW 'blank 'Circle 'blank) + blank-ROW) 2)) + +(check-expect (clack2 (make-GAME 'cross + (make-BOARD cross-blank + (make-ROW 'blank 'Circle 'blank) + blank-ROW) 2)310 310 'button-up) + (make-GAME 'Circle (make-BOARD cross-blank + (make-ROW 'blank 'Circle 'blank) + (make-ROW 'blank 'blank 'cross)) 3)) + + +(define (clack2 game x y event) + (cond [(symbol=? event 'button-up) + (play-on-game game (which-column x) (which-row y))] + [else game])) + +;; game->scene : Draws a game +;; game->scene : game -> scene + +(check-expect (game->scene (make-GAME 'Circle + (make-BOARD cross-blank blank-ROW blank-ROW) 1)) + (place-image (draw-board (make-BOARD cross-blank blank-ROW blank-ROW)) + (/ square-width 2)(/ square-width 2) background)) + + +(check-expect (game->scene (make-GAME 'cross + (make-BOARD (make-ROW 'cross 'blank 'Circle) blank-ROW blank-ROW) 1)) + (place-image (draw-board (make-BOARD (make-ROW 'cross 'blank 'Circle) blank-ROW blank-ROW)) + (/ square-width 2)(/ square-width 2) background)) + +(define (game->scene game) + (place-image (draw-board (GAME-board game)) (/ square-width 2)(/ square-width 2) background) + ) + + +;; winning-triple? : Return true if a, b, and c are all the same symbol as player. +;; winning-triple? : symbol symbol symbol symbol -> boolean + +(check-expect (winning-triple? 'cross 'cross 'cross 'cross)true) +(check-expect (winning-triple? 'Circle 'Circle 'blank 'cross)false) +(check-expect (winning-triple? 'Circle 'Circle 'Circle 'Circle)true) +(check-expect (winning-triple? 'cross 'blank 'cross 'cross)false) + + +(define (winning-triple? player a b c) + (and(and (equal? player a)(equal? player b))(equal? player c))) + + +;; winning-row? : Returns true if the indicated row is a win for the given player. +;; winning-row? : board square symbol -> boolean + +(check-expect (winning-row? (make-BOARD cross-row + circle-cross + (make-ROW 'Circle 'blank 'blank)) + 'cross 'T)true) + + + +(check-expect (winning-row? (make-BOARD (make-ROW 'cross 'blank 'Circle) + circle-cross + (make-ROW 'blank 'cross 'blank)) + 'Circle 'C)false) + + + +(check-expect (winning-row? (make-BOARD (make-ROW 'cross 'Circle 'blank ) + (make-ROW 'cross 'Circle 'cross) + (make-ROW 'Circle 'Circle 'Circle)) + 'Circle 'B)true) + +(define (winning-row? board player vertical-pos) + (cond[(equal? vertical-pos 'T)(winning-triple? player (ROW-left (BOARD-top-row board)) + (ROW-middle (BOARD-top-row board)) + (ROW-right (BOARD-top-row board)))] + [(equal? vertical-pos 'C)(winning-triple? player (ROW-left (BOARD-center-row board)) + (ROW-middle (BOARD-center-row board)) + (ROW-right (BOARD-center-row board)))] + [(equal? vertical-pos 'B)(winning-triple? player (ROW-left (BOARD-bottom-row board)) + (ROW-middle (BOARD-bottom-row board)) + (ROW-right (BOARD-bottom-row board)))] + [else false] + )) + + +;; winning-column? : Return true if the indicated column is a win for the given player. +;; winnnig-column? : board square symbol -> boolean + + +(check-expect (winning-column? (make-BOARD cross-ROW-blank + circle-cross + cross-blank) + 'cross 'L)true) + + + +(check-expect (winning-column? (make-BOARD circle-cross + circle-cross + (make-ROW 'blank 'Circle 'blank)) + 'Circle 'M)true) + + + +(check-expect (winning-column? (make-BOARD circle-cross + (make-ROW 'cross 'blank 'Circle) + (make-ROW 'Circle 'Circle 'Circle)) + 'Circle 'R)true) + +(check-expect (winning-column? (make-BOARD circle-cross + cross-blank + (make-ROW 'Circle 'Circle 'Circle)) + 'Circle 'R)false) + + +(define (winning-column? board player horizontal-pos) + (cond[(equal? horizontal-pos 'L)(winning-triple? player (ROW-left (BOARD-top-row board)) + (ROW-left (BOARD-center-row board)) + (ROW-left (BOARD-bottom-row board)))] + [(equal? horizontal-pos 'M)(winning-triple? player (ROW-middle (BOARD-top-row board)) + (ROW-middle (BOARD-center-row board)) + (ROW-middle (BOARD-bottom-row board)))] + [(equal? horizontal-pos 'R)(winning-triple? player (ROW-right (BOARD-top-row board)) + (ROW-right (BOARD-center-row board)) + (ROW-right (BOARD-bottom-row board)))] + [else false] + )) + + + +;; winning-down-diagonal? : Return true if the top-left to bottom-right diagonal is a win. +;; winning-down-diagonal? : board square -> boolean + + + + +(check-expect (winning-down-diagonal?(make-BOARD (make-ROW 'Circle 'Circle 'Circle) + (make-ROW 'cross 'Circle 'blank) + (make-ROW 'cross 'blank 'Circle)) + 'Circle)true) + +(check-expect (winning-down-diagonal?(make-BOARD circle-cross + cross-blank + (make-ROW 'Circle 'blank 'Circle)) + 'Circle)false) +(check-expect (winning-down-diagonal?(make-BOARD (make-ROW 'cross 'blank 'cross ) + (make-ROW 'Circle 'cross 'blank) + (make-ROW 'blank 'Circle 'cross)) + 'cross)true) + + +(define (winning-down-diagonal? board player) + (and (equal? player (ROW-right (BOARD-bottom-row board))) (and (equal? player(ROW-middle (BOARD-center-row board))) + (equal? player (ROW-left (BOARD-top-row board)))))) + + +;; winning-up-diagonal? : Return true if the bottom-left to top-right diagonal is a win. +;; winning-up-diagonal? : board square -> boolean + +(check-expect (winning-up-diagonal?(make-BOARD circle-cross + (make-ROW 'cross 'Circle 'blank) + (make-ROW 'Circle 'blank 'Circle)) + 'Circle)true) + +(check-expect (winning-up-diagonal?(make-BOARD circle-cross + cross-blank + (make-ROW 'Circle 'blank 'Circle)) + 'Circle)false) +(check-expect (winning-up-diagonal?(make-BOARD (make-ROW 'cross 'blank 'cross ) + (make-ROW 'Circle 'cross 'blank) + (make-ROW 'cross 'blank 'Circle)) + 'cross)true) + + +(define (winning-up-diagonal? board player) + (and (equal? player (ROW-left (BOARD-bottom-row board))) (and (equal? player(ROW-middle (BOARD-center-row board))) + (equal? player (ROW-right (BOARD-top-row board)))))) + +;; winning-board? : Returns true if the given board is a win for the given player. +;; winning-board? : board square -> boolean + +(check-expect (winning-board? (make-BOARD cross-row + circle-cross + blank-circle) + 'cross)true) + +(check-expect (winning-board? (make-BOARD circle-cross + cross-row + blank-circle) + 'cross)true) +(check-expect (winning-board? (make-BOARD circle-cross + blank-circle + cross-row ) + 'cross)true) + +(check-expect (winning-board? (make-BOARD (make-ROW 'Circle 'cross 'cross) + (make-ROW 'Circle 'cross 'Circle) + blank-circle) + 'Circle)true) +(check-expect (winning-board? (make-BOARD (make-ROW 'cross 'Circle 'cross) + circle-cross + (make-ROW 'Circle 'Circle 'blank)) + 'Circle)true) +(check-expect (winning-board? (make-BOARD cross-circle + circle-cross + (make-ROW 'Circle 'blank 'Circle)) + 'Circle)true) + +(check-expect (winning-board? (make-BOARD cross-circle + circle-cross + blank-circle) + 'Circle)true) +(check-expect (winning-board? (make-BOARD (make-ROW 'cross 'Circle 'cross) + cross-circle + (make-ROW 'Circle 'blank 'cross)) + 'cross)true) + +(define (winning-board? board player) + (or (winning-up-diagonal? board player) + (or (winning-down-diagonal? board player) + (or (winning-row? board player 'T) + (or (winning-row? board player 'C) + (or (winning-row? board player 'B) + (or (winning-column? board player 'L) + (or (winning-column? board player 'M) + (winning-column? board player 'R))))))))) + + + +;; game-over-or-win? : Returns true when the game is over either because the board is full, +;; or because someone won. +;; game-over-or-win? : game -> boolean + +(check-expect (game-over-or-win? (make-GAME 'Circle + (make-BOARD (make-ROW 'cross 'blank 'Circle) blank-ROW blank-ROW) 3))false) + + +(check-expect (game-over-or-win? (make-GAME 'Circle + (make-BOARD (make-ROW 'cross 'blank 'Circle) + (make-ROW 'blank 'cross 'Circle) + (make-ROW 'cross 'blank 'Circle))7))true) + + +(check-expect (game-over-or-win? (make-GAME 'cross + (make-BOARD cross-circle + (make-ROW 'Circle 'cross 'Circle) + (make-ROW 'cross 'Circle 'cross))9)) + true) + +(define (game-over-or-win? game) + (or (winning-board? (GAME-board game) (GAME-next-player game)) + (game-over? game))) + + +(collect-garbage) (collect-garbage) (collect-garbage) +(printf "running tests with fast path optimization in place\n") +(time (run-tests)) +(printf "running tests without fast path optimization in place\n") +(parameterize ([skip-image-equality-fast-path #t]) + (time (run-tests))) diff --git a/collects/2htdp/tests/test-image.ss b/collects/2htdp/tests/test-image.ss index ca20179c10..2372d1a0ec 100644 --- a/collects/2htdp/tests/test-image.ss +++ b/collects/2htdp/tests/test-image.ss @@ -32,7 +32,9 @@ make-ellipse make-polygon make-point - make-crop ) + make-crop + crop? + normalized-shape?) (only-in "../private/image-more.ss" bring-between swizzle) @@ -1319,6 +1321,37 @@ 2 7 (circle 4 'solid 'black))) +;; this test case checks to make sure the number of crops doesn't +;; grow when normalizing shapes. +(let* ([an-image + (crop + 0 0 50 50 + (crop + 0 10 60 60 + (crop + 10 0 60 60 + (overlay + (overlay + (ellipse 20 50 'solid 'red) + (ellipse 30 40 'solid 'black)) + (overlay + (ellipse 20 50 'solid 'red) + (ellipse 30 40 'solid 'black))))))] + [an-image+crop + (crop 40 40 10 10 an-image)]) + + (define (count-crops s) + (define crops 0) + (let loop ([s s]) + (when (crop? s) + (set! crops (+ crops 1))) + (when (struct? s) + (for-each loop (vector->list (struct->vector s))))) + crops) + + (test (+ (count-crops (normalize-shape (image-shape an-image))) 1) + => + (count-crops (normalize-shape (image-shape an-image+crop))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -1458,3 +1491,71 @@ #rx"^polygon: expected ") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; random testing of normalization +;; make sure normalization actually normalizes +;; and that normalization doesn't introduce new structs +;; + +(require redex/reduction-semantics) + +(define-language 2htdp/image + (image (rectangle size size mode color) + (line coord coord color) + (add-curve (rectangle size size mode color) + coord coord pull angle + coord coord pull angle + color) + (overlay image image) + (overlay/xy image coord coord image) + (underlay image image) + (underlay/xy image coord coord image) + (crop coord coord size size image) + (scale/xy size size image) + (scale size image) + (rotate angle image)) + + (size big-nat) + (mode 'outline 'solid "outline" "solid") + (color "red" 'red "blue" "orange" "green" "black") + (coord big-int) + (pull 0 1/2 1/3 2 (/ big-nat (+ 1 big-nat))) + (angle 0 90 45 30 180 natural (* 4 natural)) + + ; Redex tends to choose small numbers. + (big-nat (+ (* 10 natural) natural)) + (big-int (+ (* 10 integer) integer))) + +(define-namespace-anchor anchor) + +(define (image-struct-count obj) + (let ([counts (make-hash)]) + (let loop ([obj obj]) + (when (struct? obj) + (let ([stuff (vector->list (struct->vector obj))]) + (unless (member (car stuff) '(struct:translate struct:scale)) ;; skip these becuase normalization eliminates them + (hash-set! counts (car stuff) (+ 1 (hash-ref counts (car stuff) 0)))) + (for-each loop (cdr stuff))))) + (sort (hash-map counts list) string<=? #:key (λ (x) (symbol->string (car x)))))) + +(define (check-image-properties img-sexp img) + (let* ([raw-size (image-struct-count (image-shape img))] + [normalized (normalize-shape (image-shape img) values)] + [norm-size (image-struct-count normalized)]) + (unless (normalized-shape? normalized) + (error 'test-image.ss "found a non-normalized shape after normalization:\n~s" + img-sexp)) + (unless (equal? norm-size raw-size) + (error 'test-image.ss "found differing sizes for ~s:\n ~s\n ~s" + img-sexp raw-size norm-size)))) + +(time + (redex-check + 2htdp/image + image + (check-image-properties + (term image) + (eval (term image) (namespace-anchor->namespace anchor))) + #:attempts 1000)) + diff --git a/collects/compiler/private/xform.ss b/collects/compiler/private/xform.ss index b602155fec..10a7b79eae 100644 --- a/collects/compiler/private/xform.ss +++ b/collects/compiler/private/xform.ss @@ -586,22 +586,24 @@ (define per-block-push? #t) (define gc-var-stack-mode - (ormap (lambda (e) - (cond - [(and (pragma? e) - (regexp-match #rx"GC_VARIABLE_STACK_THOUGH_TABLE" (pragma-s e))) - 'table] - [(and (tok? e) - (eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL)) - 'thread-local] - [(and (tok? e) - (eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_GETSPECIFIC)) - 'getspecific] - [(and (tok? e) - (eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_FUNCTION)) - 'function] - [else #f])) - e-raw)) + (let loop ([e-raw e-raw]) + (ormap (lambda (e) + (cond + [(and (pragma? e) + (regexp-match #rx"GC_VARIABLE_STACK_THOUGH_TABLE" (pragma-s e))) + 'table] + [(and (tok? e) + (eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL)) + 'thread-local] + [(and (tok? e) + (eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_GETSPECIFIC)) + 'getspecific] + [(and (tok? e) + (eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_FUNCTION)) + 'function] + [(braces? e) (loop (seq->list (seq-in e)))] + [else #f])) + e-raw))) ;; The code produced by xform uses a number of macros. These macros ;; make the transformation about a little easier to debug, and they diff --git a/collects/drscheme/private/drscheme-normal.ss b/collects/drscheme/private/drscheme-normal.ss index 00f436a6af..b1a9386fb9 100644 --- a/collects/drscheme/private/drscheme-normal.ss +++ b/collects/drscheme/private/drscheme-normal.ss @@ -78,6 +78,9 @@ (set-splash-char-observer (λ (evt) (let ([ch (send evt get-key-code)]) + (when (and (eq? ch #\q) + (send evt get-control-down)) + (exit)) (when (char? ch) ;; as soon as something is typed, load the bitmaps (load-magic-images) diff --git a/collects/drscheme/private/drsig.ss b/collects/drscheme/private/drsig.ss index 88b8bf257e..4645b8a393 100644 --- a/collects/drscheme/private/drsig.ss +++ b/collects/drscheme/private/drsig.ss @@ -79,10 +79,11 @@ ;show-syntax-error-context )) -(define-signature drscheme:module-langauge-cm^ +(define-signature drscheme:module-language-cm^ (module-language<%>)) -(define-signature drscheme:module-language^ extends drscheme:module-langauge-cm^ +(define-signature drscheme:module-language^ extends drscheme:module-language-cm^ (add-module-language + module-language-name module-language-put-file-mixin)) (define-signature drscheme:module-langauge-tools-cm^ diff --git a/collects/drscheme/private/frame.ss b/collects/drscheme/private/frame.ss index ff8c7ca4b0..30f5f6c471 100644 --- a/collects/drscheme/private/frame.ss +++ b/collects/drscheme/private/frame.ss @@ -300,108 +300,98 @@ ;; asks the user for a .plt file, either from the web or from ;; a file on the disk and installs it. (define (install-plt-file parent) + (define pref (preferences:get 'drscheme:install-plt-dialog)) (define dialog - (instantiate dialog% () - (parent parent) - (alignment '(left center)) - (label (string-constant install-plt-file-dialog-title)))) + (new dialog% [parent parent] + [label (string-constant install-plt-file-dialog-title)] + [alignment '(left center)])) (define tab-panel - (instantiate tab-panel% () - (parent dialog) - (callback (λ (x y) (update-panels))) - (choices (list (string-constant install-plt-web-tab) - (string-constant install-plt-file-tab))))) - (define outer-swapping-panel (instantiate horizontal-panel% () - (parent tab-panel) - (stretchable-height #f))) - (define spacing-panel (instantiate horizontal-panel% () - (stretchable-width #f) - (parent outer-swapping-panel) - (min-width 20))) - (define swapping-panel (instantiate panel:single% () - (parent outer-swapping-panel) - (alignment '(left center)) - (stretchable-width #t) - (stretchable-height #f))) - (define file-panel (instantiate horizontal-panel% () - (parent swapping-panel) - (stretchable-width #t) - (stretchable-height #f))) - (define url-panel (instantiate horizontal-panel% () - (parent swapping-panel) - (stretchable-height #f))) - (define button-panel (instantiate horizontal-panel% () - (parent dialog) - (stretchable-height #f) - (alignment '(right center)))) - (define file-text-field (instantiate text-field% () - (parent file-panel) - (callback void) - (min-width 300) - (stretchable-width #t) - (label (string-constant install-plt-filename)))) - (define file-button (instantiate button% () - (parent file-panel) - (label (string-constant browse...)) - (callback (λ (x y) (browse))))) - (define url-text-field (instantiate text-field% () - (parent url-panel) - (label (string-constant install-plt-url)) - (min-width 300) - (stretchable-width #t) - (callback void))) - + (new tab-panel% [parent dialog] + [callback (λ (x y) (update-panels))] + [choices (list (string-constant install-plt-web-tab) + (string-constant install-plt-file-tab))])) + (define outer-swapping-panel + (new horizontal-panel% [parent tab-panel] + [stretchable-height #f])) + (define spacing-panel + (new horizontal-panel% [parent outer-swapping-panel] + [stretchable-width #f] + [min-width 20])) + (define swapping-panel + (new panel:single% [parent outer-swapping-panel] + [alignment '(left center)] + [stretchable-width #t] [stretchable-height #f])) + (define file-panel + (new horizontal-panel% [parent swapping-panel] + [stretchable-width #t] [stretchable-height #f])) + (define url-panel + (new horizontal-panel% [parent swapping-panel] + [stretchable-height #f])) + (define button-panel + (new horizontal-panel% [parent dialog] + [stretchable-height #f] [alignment '(right center)])) + (define file-text-field + (new text-field% [parent file-panel] + [callback void] [min-width 300] [stretchable-width #t] + [init-value (caddr pref)] + [label (string-constant install-plt-filename)])) + (define file-button + (new button% [parent file-panel] + [callback (λ (x y) (browse))] + [label (string-constant browse...)])) + (define url-text-field + (new text-field% [parent url-panel] + [min-width 300] [stretchable-width #t] [callback void] + [init-value (cadr pref)] + [label (string-constant install-plt-url)])) (define-values (ok-button cancel-button) (gui-utils:ok/cancel-buttons button-panel - (λ (x y) - (set! cancel? #f) - (send dialog show #f)) - (λ (x y) - (send dialog show #f)))) - + (λ (x y) (set! cancel? #f) (send dialog show #f)) + (λ (x y) (send dialog show #f)))) ;; browse : -> void - ;; gets the name of a file from the user and - ;; updates file-text-field + ;; gets the name of a file from the user and updates file-text-field (define (browse) (let ([filename (finder:get-file #f "" #f "" dialog)]) (when filename (send file-text-field set-value (path->string filename))))) - ;; from-web? : -> boolean ;; returns #t if the user has selected a web address (define (from-web?) (zero? (send tab-panel get-selection))) - (define cancel? #t) - (define (update-panels) - (send swapping-panel active-child - (if (from-web?) - url-panel - file-panel))) - + (define w? (from-web?)) + (define t (if w? url-text-field file-text-field)) + (send swapping-panel active-child (if w? url-panel file-panel)) + (send t focus) + (send (send t get-editor) set-position + 0 (string-length (send t get-value)))) + ;; initialize + (send tab-panel set-selection (if (car pref) 0 1)) (update-panels) (send dialog show #t) - + (preferences:set 'drscheme:install-plt-dialog + (list (from-web?) + (send url-text-field get-value) + (send file-text-field get-value))) (cond [cancel? (void)] [(from-web?) - (install-plt-from-url (trim-whitespace (send url-text-field get-value)) parent)] - [else - (parameterize ([error-display-handler drscheme:init:original-error-display-handler]) - (run-installer (string->path (send file-text-field get-value))))])) - - ;; trim-whitespace: string -> string - ;; Trims the whitespace surrounding a string. - (define (trim-whitespace a-str) - (cond - [(regexp-match #px"^\\s*(.*[^\\s])\\s*$" - a-str) - => second] - [else - a-str])) - + (install-plt-from-url + (let* ([url (send url-text-field get-value)] + ;; trim whitespaces + [url (regexp-replace #rx"^ +" url "")] + [url (regexp-replace #rx" +$" url "")]) + (if (regexp-match? #rx"^(?:[^/:]*://|$)" url) + url + (string-append "http://" url))) + parent)] + [else (parameterize ([error-display-handler + drscheme:init:original-error-display-handler]) + (run-installer + (string->path (send file-text-field get-value))))])) + ;; install-plt-from-url : string (union #f dialog%) -> void ;; downloads and installs a .plt file from the given url (define (install-plt-from-url s-url parent) diff --git a/collects/drscheme/private/language-configuration.ss b/collects/drscheme/private/language-configuration.ss index 0c4ffd5d82..68af30ed1b 100644 --- a/collects/drscheme/private/language-configuration.ss +++ b/collects/drscheme/private/language-configuration.ss @@ -19,6 +19,11 @@ (define original-output (current-output-port)) (define (printfo . args) (apply fprintf original-output args)) + (define sc-use-language-in-source "Use the language declared in the source") + (define sc-choose-a-language "Choose a language") + (define sc-lang-in-source-discussion + "The #lang line at the start of a program declares its language. This is the default and preferred mode for DrScheme.") + (provide language-configuration@) (define-unit language-configuration@ @@ -28,7 +33,8 @@ [prefix drscheme:language: drscheme:language^] [prefix drscheme:app: drscheme:app^] [prefix drscheme:tools: drscheme:tools^] - [prefix drscheme:help-desk: drscheme:help-desk^]) + [prefix drscheme:help-desk: drscheme:help-desk^] + [prefix drscheme:module-language: drscheme:module-language^]) (export drscheme:language-configuration/internal^) ;; settings-preferences-symbol : symbol @@ -341,9 +347,11 @@ cached-fringe) (define/override (on-select i) - (if (and i (is-a? i hieritem-language<%>)) - (something-selected i) - (nothing-selected))) + (cond + [(and i (is-a? i hieritem-language<%>)) + (something-selected i)] + [else + (non-language-selected)])) ;; this is used only because we set `on-click-always' (define/override (on-click i) (when (and i (is-a? i hierarchical-list-compound-item<%>)) @@ -353,12 +361,55 @@ (when (and i (is-a? i hieritem-language<%>)) (something-selected i) (ok-handler 'execute))) - (super-instantiate (parent)) + (super-new [parent parent]) ;; do this so we can expand/collapse languages on a single click (send this on-click-always #t))) (define outermost-panel (make-object horizontal-pane% parent)) - (define languages-hier-list (make-object selectable-hierlist% outermost-panel)) + (define languages-choice-panel (new vertical-panel% + [parent outermost-panel] + [alignment '(left top)])) + + (define use-language-in-source-rb + (new radio-box% + [label #f] + [choices (list sc-use-language-in-source)] + [parent languages-choice-panel] + [callback + (λ (rb evt) + (module-language-selected) + (send use-chosen-language-rb set-selection #f))])) + (define in-source-discussion-panel (new horizontal-panel% + [parent languages-choice-panel] + [stretchable-height #f])) + (define in-source-discussion-spacer (new horizontal-panel% + [parent in-source-discussion-panel] + [stretchable-width #f] + [min-width 32])) + (define stupid-internal-definition-syntax1 (add-discussion in-source-discussion-panel)) + (define use-chosen-language-rb + (new radio-box% + [label #f] + [choices (list sc-choose-a-language)] + [parent languages-choice-panel] + [callback + (λ (this-rb evt) + (let ([i (send languages-hier-list get-selected)]) + (cond + [(and i (is-a? i hieritem-language<%>)) + (something-selected i)] + [else + (non-language-selected)])) + (send use-language-in-source-rb set-selection #f))])) + (define languages-hier-list-panel (new horizontal-panel% [parent languages-choice-panel])) + (define languages-hier-list-spacer (new horizontal-panel% + [parent languages-hier-list-panel] + [stretchable-width #f] + [min-width 16])) + + (define languages-hier-list (new selectable-hierlist% + [parent languages-hier-list-panel] + [style '(no-border no-hscroll hide-vscroll transparent)])) (define details-outer-panel (make-object vertical-pane% outermost-panel)) (define details/manual-parent-panel (make-object vertical-panel% details-outer-panel)) (define details-panel (make-object panel:single% details/manual-parent-panel)) @@ -395,19 +446,39 @@ (init-rest args) (public selected) (define (selected) - (let ([ldp (get-language-details-panel)]) - (when ldp - (send details-panel active-child ldp))) - (send one-line-summary-message set-label (send language get-one-line-summary)) - (send revert-to-defaults-button enable #t) - (set! get/set-selected-language-settings get/set-settings) - (set! selected-language language)) + (update-gui-based-on-selected-language language get-language-details-panel get/set-settings)) (apply super-make-object args)))) - ;; nothing-selected : -> void + (define (update-gui-based-on-selected-language language get-language-details-panel get/set-settings) + (let ([ldp (get-language-details-panel)]) + (when ldp + (send details-panel active-child ldp))) + (send one-line-summary-message set-label (send language get-one-line-summary)) + (send revert-to-defaults-button enable #t) + (set! get/set-selected-language-settings get/set-settings) + (set! selected-language language)) + + (define (module-language-selected) + ;; need to deselect things in the languages-hier-list at this point. + ;(send languages-hier-list select #f) + (send use-chosen-language-rb set-selection #f) + (send use-language-in-source-rb set-selection 0) + (ok-handler 'enable) + (send details-button enable #t) + (update-gui-based-on-selected-language module-language*language + module-language*get-language-details-panel + module-language*get/set-settings)) + + (define module-language*language 'module-language*-not-yet-set) + (define module-language*get-language-details-panel 'module-language*-not-yet-set) + (define module-language*get/set-settings 'module-language*-not-yet-set) + + ;; non-language-selected : -> void ;; updates the GUI and selected-language and get/set-selected-language-settings - ;; for when no language is selected. - (define (nothing-selected) + ;; for when some non-language is selected in the hierlist + (define (non-language-selected) + (send use-chosen-language-rb set-selection 0) + (send use-language-in-source-rb set-selection #f) (send revert-to-defaults-button enable #f) (send details-panel active-child no-details-panel) (send one-line-summary-message set-label "") @@ -418,7 +489,9 @@ ;; something-selected : item -> void (define (something-selected item) - (ok-handler 'enable) + (send use-chosen-language-rb set-selection 0) + (send use-language-in-source-rb set-selection #f) + (ok-handler 'enable) (send details-button enable #t) (send item selected)) @@ -449,7 +522,7 @@ positions numbers)) (when (null? (cdr positions)) - (unless (equal? positions (list "Module")) + (unless (equal? positions (list drscheme:module-language:module-language-name)) (error 'drscheme:language "Only the module language may be at the top level. Other languages must have at least two levels"))) @@ -488,17 +561,7 @@ [get-language-details-panel (lambda () language-details-panel)] [get/set-settings (lambda x (apply real-get/set-settings x))] [position (car positions)] - [number (car numbers)] - [mixin (compose - number-mixin - (language-mixin language get-language-details-panel get/set-settings))] - [item - (send hier-list new-item - (if second-number - (compose second-number-mixin mixin) - mixin))] - [text (send item get-editor)] - [delta (send language get-style-delta)]) + [number (car numbers)]) (set! construct-details (let ([old construct-details]) @@ -529,24 +592,40 @@ [else (get/set-settings (send language default-settings))]))))) - (send item set-number number) - (when second-number - (send item set-second-number second-number)) - (send text insert position) - (when delta - (cond - [(list? delta) - (for-each (λ (x) - (send text change-style - (car x) - (cadr x) - (caddr x))) - delta)] - [(is-a? delta style-delta%) - (send text change-style - (send language get-style-delta) - 0 - (send text last-position))])))] + (cond + [(equal? positions (list drscheme:module-language:module-language-name)) + (set! module-language*language language) + (set! module-language*get-language-details-panel get-language-details-panel) + (set! module-language*get/set-settings get/set-settings)] + [else + (let* ([mixin (compose + number-mixin + (language-mixin language get-language-details-panel get/set-settings))] + [item + (send hier-list new-item + (if second-number + (compose second-number-mixin mixin) + mixin))] + [text (send item get-editor)] + [delta (send language get-style-delta)]) + (send item set-number number) + (when second-number + (send item set-second-number second-number)) + (send text insert position) + (when delta + (cond + [(list? delta) + (for-each (λ (x) + (send text change-style + (car x) + (cadr x) + (caddr x))) + delta)] + [(is-a? delta style-delta%) + (send text change-style + (send language get-style-delta) + 0 + (send text last-position))])))]))] [else (let* ([position (car positions)] [number (car numbers)] [sub-ht/sub-hier-list @@ -662,32 +741,38 @@ ;; and selects the current language (define (open-current-language) (when (and language-to-show settings-to-show) - (let ([language-position (send language-to-show get-language-position)]) - (cond - [(null? (cdr language-position)) - ;; nothing to open here - ;; this should only be the module language - (send (car (send languages-hier-list get-items)) select #t) - (void)] - [else - (let loop ([hi languages-hier-list] - - ;; skip the first position, since it is flattened into the dialog - [first-pos (cadr language-position)] - [position (cddr language-position)]) - (let ([child - ;; know that this `car' is okay by construction of the dialog - (car - (filter (λ (x) - (equal? (send (send x get-editor) get-text) - first-pos)) - (send hi get-items)))]) - (cond - [(null? position) - (send child select #t)] - [else - (send child open) - (loop child (car position) (cdr position))])))])))) + (cond + [(equal? language-to-show + module-language*language) + (module-language-selected)] + [else + (send use-chosen-language-rb set-selection 0) + (send use-language-in-source-rb set-selection #f) + (let ([language-position (send language-to-show get-language-position)]) + (cond + [(null? (cdr language-position)) + ;; nothing to open here + (send (car (send languages-hier-list get-items)) select #t) + (void)] + [else + (let loop ([hi languages-hier-list] + + ;; skip the first position, since it is flattened into the dialog + [first-pos (cadr language-position)] + [position (cddr language-position)]) + (let ([child + ;; know that this `car' is okay by construction of the dialog + (car + (filter (λ (x) + (equal? (send (send x get-editor) get-text) + first-pos)) + (send hi get-items)))]) + (cond + [(null? position) + (send child select #t)] + [else + (send child open) + (loop child (car position) (cdr position))])))]))]))) ;; docs-callback : -> void (define (docs-callback) @@ -826,6 +911,44 @@ (and get/set-selected-language-settings (get/set-selected-language-settings)))))) + (define (add-discussion p) + (let* ([t (new text:standard-style-list%)] + [c (new editor-canvas% + [stretchable-width #t] + [horizontal-inset 0] + [vertical-inset 0] + [parent p] + [style '(no-border auto-vscroll no-hscroll transparent)] + [editor t])]) + (send c set-line-count 3) + + (send t set-styles-sticky #f) + (send t set-autowrap-bitmap #f) + (let* ([size-sd (make-object style-delta% 'change-size (send normal-control-font get-point-size))] + [do-insert + (λ (str tt-style?) + (let ([before (send t last-position)]) + (send t insert str before before) + (cond + [tt-style? + (send t change-style + (send (send t get-style-list) find-named-style "Standard") + before (send t last-position))] + [else + (send t change-style + (send (send t get-style-list) basic-style) + before (send t last-position))]) + (send t change-style size-sd before (send t last-position))))]) + (let loop ([strs (regexp-split #rx"#lang" sc-lang-in-source-discussion)]) + (do-insert (car strs) #f) + (unless (null? (cdr strs)) + (do-insert "#lang" #t) + (loop (cdr strs))))) + (send t hide-caret #t) + + (send t auto-wrap #t) + (send t lock #t))) + (define panel-background-editor-canvas% (class editor-canvas% (inherit get-dc get-client-size) diff --git a/collects/drscheme/private/main.ss b/collects/drscheme/private/main.ss index 2e759a83d9..1f46e3d613 100644 --- a/collects/drscheme/private/main.ss +++ b/collects/drscheme/private/main.ss @@ -152,6 +152,11 @@ (λ (x) (and (list? x) (andmap (λ (x) (or (path? x) (drscheme:frame:planet-spec? x))) x)))) +(preferences:set-default 'drscheme:install-plt-dialog + '(#t "" "") ; url-selected?, url string, file string + (λ (x) (and (list? x) (= 3 (length x)) + (boolean? (car x)) + (andmap string? (cdr x))))) (preferences:set-un/marshall 'drscheme:user-defined-keybindings diff --git a/collects/drscheme/private/module-language.ss b/collects/drscheme/private/module-language.ss index 1c56cc64f2..be1b0ab6da 100644 --- a/collects/drscheme/private/module-language.ss +++ b/collects/drscheme/private/module-language.ss @@ -29,7 +29,7 @@ (define module-language<%> (interface () - )) + get-users-language-name)) ;; add-module-language : -> void ;; adds the special module-only language to drscheme @@ -53,10 +53,24 @@ (define default-full-trace? #t) (define default-auto-text "#lang scheme\n") + (define module-language-name "Determine langauge from source") + ;; module-mixin : (implements drscheme:language:language<%>) ;; -> (implements drscheme:language:language<%>) (define (module-mixin %) (class* % (drscheme:language:language<%> module-language<%>) + + (inherit get-language-name) + (define/public (get-users-language-name defs-text) + (let* ([i (open-input-text-editor defs-text)] + [l (with-handlers ((exn:fail? (λ (x) '?))) + (read-language i (lambda () '?)))]) + (if (eq? '? l) + (get-language-name) + (regexp-replace #rx".*#(?:!|lang ) *" + (send defs-text get-text 0 (file-position i)) + "")))) + (define/override (use-namespace-require/copy?) #f) (define/augment (capability-value key) @@ -328,7 +342,7 @@ (super-new [module #f] - [language-position (list "Module")] + [language-position (list module-language-name)] [language-numbers (list -32768)]))) ;; can be called with #f to just kill the repl (in case we want to kill it diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss index cf1f339e26..4c272b9644 100644 --- a/collects/drscheme/private/rep.ss +++ b/collects/drscheme/private/rep.ss @@ -89,7 +89,8 @@ TODO (prefix drscheme:text: drscheme:text^) (prefix drscheme:help-desk: drscheme:help-desk^) (prefix drscheme:debug: drscheme:debug^) - [prefix drscheme:eval: drscheme:eval^]) + [prefix drscheme:eval: drscheme:eval^] + [prefix drscheme:module-language: drscheme:module-language^]) (export (rename drscheme:rep^ [-text% text%] [-text<%> text<%>])) @@ -402,9 +403,15 @@ TODO default-settings? (drscheme:language-configuration:language-settings-settings language-settings))) - (define (extract-language-name language-settings) - (send (drscheme:language-configuration:language-settings-language language-settings) - get-language-name)) + (define (extract-language-name language-settings defs-text) + (cond + [(is-a? (drscheme:language-configuration:language-settings-language language-settings) + drscheme:module-language:module-language<%>) + (send (drscheme:language-configuration:language-settings-language language-settings) + get-users-language-name defs-text)] + [else + (send (drscheme:language-configuration:language-settings-language language-settings) + get-language-name)])) (define (extract-language-style-delta language-settings) (send (drscheme:language-configuration:language-settings-language language-settings) get-style-delta)) @@ -1587,7 +1594,7 @@ TODO (let-values (((before after) (insert/delta this - (extract-language-name user-language-settings) + (extract-language-name user-language-settings definitions-text) dark-green-delta (extract-language-style-delta user-language-settings))) ((url) (extract-language-url user-language-settings))) @@ -1618,6 +1625,7 @@ TODO (reset-regions (list (list (last-position) (last-position)))) (set-unread-start-point (last-position)) (set-insertion-point (last-position)) + (set! indenting-limit (last-position)) (set-allow-edits #f) (set! repl-header-end #f) (end-edit-sequence)) @@ -1653,6 +1661,12 @@ TODO (end-edit-sequence) (clear-undos)) + (define indenting-limit 0) + (define/override (get-limit n) + (cond + [(< n indenting-limit) 0] + [else indenting-limit])) + ;; avoid calling paragraph-start-position very often. (define repl-header-end #f) (define/private (get-repl-header-end) diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index c531f0bfb3..8f3f76e4c4 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -1758,6 +1758,9 @@ WARNING: printf is rebound in the body of the unit to always (define clever-file-format-mixin (mixin ((class->interface text%)) (clever-file-format<%>) (inherit get-file-format set-file-format find-first-snip) + + ;; all-string-snips : -> boolean + ;; returns #t when it is safe to save this file in 'text mode. (define/private (all-string-snips) (let loop ([s (find-first-snip)]) (cond @@ -1765,6 +1768,7 @@ WARNING: printf is rebound in the body of the unit to always [(is-a? s string-snip%) (loop (send s next))] [else #f]))) + (define/augment (on-save-file name format) (let ([all-strings? (all-string-snips)]) (cond diff --git a/collects/framework/splash.ss b/collects/framework/splash.ss index c3fa1f3aad..f2908f2501 100644 --- a/collects/framework/splash.ss +++ b/collects/framework/splash.ss @@ -280,19 +280,11 @@ (define quit-on-close? #t) (define splash-tlw% - (case (system-type) - [(unix) - (class dialog% - (define/augment (on-close) - (when quit-on-close? - (exit))) - (super-new))] - [else - (class frame% - (define/augment (on-close) - (when quit-on-close? - (exit))) - (super-new [style '(no-resize-border)]))])) + (class dialog% + (define/augment (on-close) + (when quit-on-close? + (exit))) + (super-new))) (define splash-canvas% (class canvas% diff --git a/collects/honu/main.ss b/collects/honu/main.ss index 276d7b890a..c45f275fa8 100644 --- a/collects/honu/main.ss +++ b/collects/honu/main.ss @@ -1,6 +1,7 @@ #lang scheme/base (require "private/honu-typed-scheme.ss" + ;; "private/honu.ss" "private/macro.ss") (provide (rename-out (#%dynamic-honu-module-begin #%module-begin) @@ -10,11 +11,15 @@ (honu-* *) (honu-/ /) (honu-- -) + (honu-? ?) + (honu-: :) + (honu-comma |,|) ) #%datum true false display + display2 newline else (rename-out diff --git a/collects/honu/private/honu-typed-scheme.ss b/collects/honu/private/honu-typed-scheme.ss index 1c767b9618..62c9ba0d6f 100644 --- a/collects/honu/private/honu-typed-scheme.ss +++ b/collects/honu/private/honu-typed-scheme.ss @@ -6,6 +6,7 @@ syntax/name syntax/define syntax/parse + syntax/parse/experimental scheme/splicing "contexts.ss" "util.ss" @@ -22,17 +23,18 @@ ;; macro for defining literal tokens that can be used in macros (define-syntax-rule (define-literal name ...) (begin - (define-syntax name (lambda (stx) - (raise-syntax-error 'name - "this is a literal and cannot be used outside a macro"))) - ...)) + (define-syntax name (lambda (stx) + (raise-syntax-error 'name + "this is a literal and cannot be used outside a macro"))) + ...)) (define-literal honu-return) (define-literal semicolon) (define-literal honu-+ honu-* honu-/ honu-- honu-|| honu-% honu-= honu-+= honu--= honu-*= honu-/= honu-%= honu-&= honu-^= honu-\|= honu-<<= honu->>= honu->>>= - honu->> honu-<< honu->>> honu-< honu-> honu-<= honu->=) + honu->> honu-<< honu->>> honu-< honu-> honu-<= honu->= + honu-? honu-: honu-comma) ;; (define-syntax (\; stx) (raise-syntax-error '\; "out of context" stx)) @@ -43,9 +45,9 @@ (define-values (struct:honu-trans make-honu-trans honu-trans? honu-trans-ref honu-trans-set!) - (make-struct-type 'honu-trans #f 1 0 #f - (list (list prop:honu-transformer #t)) - (current-inspector) 0)) + (make-struct-type 'honu-trans #f 1 0 #f + (list (list prop:honu-transformer #t)) + (current-inspector) 0)) (define (make-honu-transformer proc) (unless (and (procedure? proc) @@ -66,6 +68,7 @@ (and (positive? (string-length str)) (memq (string-ref str 0) sym-chars))))))) +;; returns a transformer or #f (define (get-transformer stx) ;; if its an identifier and bound to a transformer return it (define (bound-transformer stx) @@ -355,6 +358,7 @@ x(2) |# + (define (parse-block-one/2 stx context) (define (parse-one stx context) (define-syntax-class block @@ -364,28 +368,63 @@ x(2) [pattern (type:id name:id (#%parens args ...) body:block . rest) #:with result #'(define (name args ...) body.result)]) - (define-syntax-class expr - [pattern f]) + + (define (syntax-object-position mstart end) + (if (stx-null? end) + (length (syntax->list mstart)) + (let loop ([start mstart] + [count 0]) + ;; (printf "Checking ~a vs ~a\n" start end) + (cond + [(stx-null? start) (raise-syntax-error 'honu-macro "the `rest' syntax returned by a honu macro did not return objects at the same syntactic nesting level as the head of the pattern. this is probably because it returned syntax from some inner nesting level such as (if (x + 1 2) more-stuff) where `rest' was (+ 1 2) instead of `more-stuff'" end mstart)] + [(eq? (stx-car start) (stx-car end)) count] + ;; [(equal? start end) count] + [else (loop (stx-cdr start) (add1 count))])))) + + (define-primitive-splicing-syntax-class (expr) + #:attrs (result) + #:description "expr" + (lambda (stx fail) + (cond + [(stx-null? stx) (fail)] + [(get-transformer stx) => (lambda (transformer) + (let-values ([(used rest) + (transformer stx context)]) + (list rest (syntax-object-position stx rest) + used)))] + + [else (syntax-case stx () + [(f . rest) (list #'rest 1 #'f)])]))) + + #; + (define-splicing-syntax-class expr + [pattern (~seq f ...) #:with result]) (define-splicing-syntax-class call - [pattern (~seq e:expr (#%parens arg:expression-1)) - #:with call #'(e arg.result)]) + #:literals (honu-comma) + [pattern (~seq e:expr (#%parens (~seq arg:ternary (~optional honu-comma)) ...)) + #:with call #'(e.result arg.result ...)]) (define-splicing-syntax-class expression-last [pattern (~seq call:call) #:with result #'call.call] [pattern (~seq x:number) #:with result #'x] + [pattern (~seq e:expr) #:with result #'e.result] ) (define-syntax-rule (define-infix-operator name next [operator reducer] ...) - (define-splicing-syntax-class name - #:literals (operator ...) - [pattern (~seq (~var left next) operator (~var right name)) - #:with result (reducer #'left.result #'right.result)] - ... - [pattern (~seq (~var exp next)) - #:with result #'exp.result] - )) + (begin + (define-syntax-class operator-class + #:literals (operator ...) + (pattern operator #:attr func reducer) + ...) + (define-splicing-syntax-class name + (pattern (~seq (~var left next) + (~optional (~seq (~var op operator-class) (~var right name)))) + #:with result + (cond [(attribute right) + ((attribute op.func) #'left.result #'right.result)] + [else + #'left.result]))))) - ;; TODO: maybe just have a precedence macro that creates all these constructs ;; (infix-operators ([honu-* ...] ;; [honu-- ...]) ;; ([honu-+ ...] @@ -414,23 +453,6 @@ x(2) #'(begin result ...)))])) - #; - (infix-operators expression-1 expression-last - ([honu-+ (syntax-lambda (left right) - #'(+ left right))] - [honu-- (syntax-lambda (left right) - #'(- left right))]) - ([honu-* (syntax-lambda (left right) - #'(* left right))] - [honu-/ (syntax-lambda (left right) - #'(/ left right))])) - - - (define-syntax-class expression-top - [pattern (e:expression-1 semicolon . rest) - #:with result #'e.result]) - - ;; infix operators in the appropriate precedence level ;; things defined lower in the table have a higher precedence. ;; the first set of operators is `expression-1' @@ -462,10 +484,25 @@ x(2) [honu-% (sl (left right) #'(modulo left right))] [honu-/ (sl (left right) #'(/ left right))]))) + (define-splicing-syntax-class ternary + #:literals (honu-? honu-:) + [pattern (~seq condition:expression-1 (~optional (~seq honu-? on-true:ternary + honu-: on-false:ternary))) + #:with result + (cond [(attribute on-true) + #'(if condition.result on-true.result on-false.result)] + [else #'condition.result])]) + + (define-syntax-class expression-top + #:literals (semicolon) + [pattern (e:ternary semicolon . rest) + #:with result #'e.result]) + ;; (printf "~a\n" (syntax-class-parse function stx)) (syntax-parse stx [function:function (values #'function.result #'function.rest)] [expr:expression-top (values #'expr.result #'expr.rest)] + #; [(x:number . rest) (values #'x #'rest)] )) (cond @@ -519,7 +556,7 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt (lambda (stx ctx) (define (parse-complete-block stx) ;; (printf "Parsing complete block ~a\n" (syntax->datum stx)) - (with-syntax ([(exprs ...) (parse-block stx ctx)]) + (with-syntax ([(exprs ...) (parse-block stx the-expression-block-context)]) #'(begin exprs ...)) #; (let-values ([(a b) @@ -551,7 +588,7 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt [(_ condition:paren-expr on-true:block else on-false:block . rest) ;; (printf "used if with else\n") (let ([result #'(if condition.expr on-true.line on-false.line)]) - (expression-result ctx result #'rest))] + (expression-result ctx result (syntax/loc #'rest rest)))] [(_ condition:paren-expr on-true:block . rest) ;; (printf "used if with no else\n") (let ([result #'(when condition.expr on-true.line)]) @@ -643,11 +680,16 @@ if (foo){ (define-syntax (honu-top stx) (raise-syntax-error #f "interactive use is not yet supported")) +(define (display2 x y) + (printf "~a ~a" x y)) + (define-syntax (honu-unparsed-begin stx) ;; (printf "honu unparsed begin: ~a\n" (syntax->datum stx)) (syntax-case stx () [(_) #'(begin (void))] [(_ . body) (let-values ([(code rest) (parse-block-one/2 #'body + the-expression-context + #; the-top-block-context)]) ;; (printf "Rest is ~a\n" (syntax->datum rest)) (with-syntax ([code code] diff --git a/collects/macro-debugger/expand.ss b/collects/macro-debugger/expand.ss index 29f6d772ef..48d4c22007 100644 --- a/collects/macro-debugger/expand.ss +++ b/collects/macro-debugger/expand.ss @@ -25,7 +25,7 @@ (define (expand/show-predicate stx show?) (let-values ([(result deriv) (trace/result stx)]) (when (exn? result) (raise result)) - (let-values ([(_steps _uses stx exn2) + (let-values ([(_steps _defs _uses stx exn2) (parameterize ((macro-policy show?)) (reductions+ deriv))]) (when (exn? exn2) (raise exn2)) diff --git a/collects/macro-debugger/stepper-text.ss b/collects/macro-debugger/stepper-text.ss index 3df8213c8b..327b52a72c 100644 --- a/collects/macro-debugger/stepper-text.ss +++ b/collects/macro-debugger/stepper-text.ss @@ -93,13 +93,6 @@ ((if display-like? display write) (syntax-dummy-val obj) port)] [else (error 'pretty-print-hook "unexpected special value: ~e" obj)])) - (define (pp-extend-style-table) - (let* ([ids identifier-list] - [syms (map (lambda (x) (hash-ref stx=>flat x)) ids)] - [like-syms (map syntax-e ids)]) - (pretty-print-extend-style-table (pp-better-style-table) - syms - like-syms))) (define (pp-better-style-table) (pretty-print-extend-style-table (pretty-print-current-style-table) (map car extended-style-list) @@ -107,7 +100,7 @@ (parameterize ([pretty-print-size-hook pp-size-hook] [pretty-print-print-hook pp-print-hook] - [pretty-print-current-style-table (pp-extend-style-table)]) + [pretty-print-current-style-table (pp-better-style-table)]) (pretty-print/defaults datum))) (define (->show-function show) diff --git a/collects/meta/dist-specs.ss b/collects/meta/dist-specs.ss index b96401b67b..0e0547c390 100644 --- a/collects/meta/dist-specs.ss +++ b/collects/meta/dist-specs.ss @@ -344,7 +344,7 @@ mz-manuals := (scribblings: "main/") ; generates main pages (next line) (notes: "COPYING.LIB" "COPYING-libscheme.txt") (doc: "doc-license.txt") ; needed (when docs are included) (doc+src: "reference/" "guide/" "quick/" "more/" - "foreign/" "inside/" "futures/" + "foreign/" "inside/" "futures/" "places/" "honu/") (doc: "*.{html|css|js|sxref}") (scribblings: "{{info|icons}.ss|*.png}" "compiled") diff --git a/collects/mred/private/check.ss b/collects/mred/private/check.ss index 9872d3550e..d46c1996d1 100644 --- a/collects/mred/private/check.ss +++ b/collects/mred/private/check.ss @@ -117,7 +117,7 @@ (unless (and (integer? i) (exact? i) (not (negative? i))) (raise-type-error (who->name who) (if false-ok? - "non-negative exact integeror #f" + "non-negative exact integer or #f" "non-negative exact integer" ) i)))) diff --git a/collects/mred/private/mritem.ss b/collects/mred/private/mritem.ss index 226d144d1a..31231d5c1e 100644 --- a/collects/mred/private/mritem.ss +++ b/collects/mred/private/mritem.ss @@ -264,40 +264,47 @@ (check-container-parent cwho parent) (check-callback cwho callback) (check-orientation cwho style) - (check-non-negative-integer cwho selection))) + (check-non-negative-integer/false cwho selection))) (private-field [wx #f]) (private [check-button - (lambda (method n) - (check-non-negative-integer `(method radio-box% ,method) n) - (unless (< n (length chcs)) - (raise-mismatch-error (who->name `(method radio-box% ,method)) "no such button: " n)))]) + (lambda (method n false-ok?) + ((if false-ok? + check-non-negative-integer/false + check-non-negative-integer) + `(method radio-box% ,method) n) + (when n + (unless (< n (length chcs)) + (raise-mismatch-error (who->name `(method radio-box% ,method)) "no such button: " n))))]) (override [enable (entry-point (case-lambda [(on?) (send wx enable on?)] - [(which on?) (check-button 'enable which) + [(which on?) (check-button 'enable which #f) (send wx enable which on?)]))] [is-enabled? (entry-point (case-lambda [() (send wx is-enabled?)] - [(which) (check-button 'is-enabled? which) + [(which) (check-button 'is-enabled? which #f) (send wx is-enabled? which)]))]) (public [get-number (lambda () (length chcs))] [get-item-label (lambda (n) - (check-button 'get-item-label n) + (check-button 'get-item-label n #f) (list-ref chcs n))] [get-item-plain-label (lambda (n) - (check-button 'get-item-plain-label n) + (check-button 'get-item-plain-label n #f) (wx:label->plain-label (list-ref chcs n)))] - [get-selection (entry-point (lambda () (send wx get-selection)))] + [get-selection (entry-point (lambda () (let ([v (send wx get-selection)]) + (if (equal? v -1) + #f + v))))] [set-selection (entry-point (lambda (v) - (check-button 'set-selection v) - (send wx set-selection v)))]) + (check-button 'set-selection v #t) + (send wx set-selection (or v -1))))]) (sequence (as-entry (lambda () @@ -317,7 +324,7 @@ (length choices)) selection)))) label parent callback #f))) - (when (positive? selection) + (when (or (not selection) (positive? selection)) (set-selection selection))))) (define slider% diff --git a/collects/mred/private/wxme/style.ss b/collects/mred/private/wxme/style.ss index 3ac2ef9444..8bb830a326 100644 --- a/collects/mred/private/wxme/style.ss +++ b/collects/mred/private/wxme/style.ss @@ -621,7 +621,7 @@ (define/public (s-set-as-basic slist) (set! style-list slist) - (set! name "basic") + (set! name "Basic") (set! base-style #f) (set! nonjoin-delta (new style-delta%)) diff --git a/collects/mrlib/hierlist/hierlist-unit.ss b/collects/mrlib/hierlist/hierlist-unit.ss index 6a0b026aff..b06a7ed114 100644 --- a/collects/mrlib/hierlist/hierlist-unit.ss +++ b/collects/mrlib/hierlist/hierlist-unit.ss @@ -10,10 +10,10 @@ (require (rename mzlib/list sort* sort) mzlib/etc) - (define turn-up (include-bitmap "../../icons/turn-up.png" 'png)) - (define turn-down (include-bitmap "../../icons/turn-down.png" 'png)) - (define turn-up-click (include-bitmap "../../icons/turn-up-click.png" 'png)) - (define turn-down-click (include-bitmap "../../icons/turn-down-click.png" 'png)) + (define turn-up (include-bitmap "../../icons/turn-up.png" 'png/mask)) + (define turn-down (include-bitmap "../../icons/turn-down.png" 'png/mask)) + (define turn-up-click (include-bitmap "../../icons/turn-up-click.png" 'png/mask)) + (define turn-down-click (include-bitmap "../../icons/turn-down-click.png" 'png/mask)) (provide hierlist@) (define-unit hierlist@ @@ -93,7 +93,10 @@ (send dc draw-bitmap-section bitmap (+ x (max 0 (- (/ size 2) (/ bw 2)))) (+ y (max 0 (- (/ size 2) (/ bh 2)))) - 0 0 (min bw (+ size 2)) (min bh (+ size 2)))))] + 0 0 (min bw (+ size 2)) (min bh (+ size 2)) + 'solid + (send the-color-database find-color "black") + (send bitmap get-loaded-mask))))] [size-cache-invalid (lambda () (set! size-calculated? #f))] [on-event (lambda (dc x y mediax mediay event) @@ -340,7 +343,8 @@ [parent-snip parent-snp] [children null] [new-children null] - [no-sublists? #f]) + [no-sublists? #f] + [transparent? #f]) (private [append-children! (lambda () (unless (null? new-children) @@ -350,17 +354,19 @@ [insert-item (lambda (mixin snip% whitespace?) (let ([s (make-object snip% this top top-select (add1 depth) mixin)]) + (send s use-style-background transparent?) (begin-edit-sequence) (unless (and (null? children) (null? new-children)) (insert #\newline (last-position))) (when whitespace? - (insert (make-whitespace) (last-position))) + (insert (make-whitespace) (last-position))) (insert s (last-position)) (end-edit-sequence) (set! new-children (cons s new-children)) (send s get-item)))]) (public + [set-transparent (λ (t?) (set! transparent? (and t? #t)))] [get-parent-snip (lambda () parent-snip)] [deselect-all (lambda () @@ -479,7 +485,7 @@ ;; Snip for a compound list item (define hierarchical-list-snip% - (class100 editor-snip% (prnt tp top-select depth mixin [title #f][content #f]) + (class100 editor-snip% (prnt tp top-select depth mixin [title #f][content #f]) (private-field [parent prnt] [top tp]) @@ -583,11 +589,19 @@ [content-snip (make-object editor-snip% content-buffer #f 4 0 0 0 0 0 0 0)] [arrow (make-object (get-arrow-snip%) (lambda (a) (on-arrow a)))] [whitespace (make-object whitespace-snip%)]) + (override + [use-style-background + (λ (x) + (super use-style-background x) + (send title-snip use-style-background x) + (send content-snip use-style-background x) + (send content-buffer set-transparent x))]) (public [get-arrow-snip (lambda () arrow)]) - (sequence + (inherit style-background-used?) + (sequence (super-init main-buffer #f 0 0 0 0 0 0 0 0) - (send main-buffer hide-caret #t) + (send main-buffer hide-caret #t) (send main-buffer insert arrow) (when title (send title-buffer insert title)) (when content (send content-buffer insert content)) @@ -637,7 +651,7 @@ (send list-keymap map-function "return" "toggle-open/closed") (define hierarchical-list% - (class100 editor-canvas% (parent [style '(no-hscroll)]) + (class100 editor-canvas% (parent [style '(no-hscroll)]) (inherit min-width min-height allow-tab-exit) (rename [super-on-char on-char] [super-on-focus on-focus]) @@ -702,8 +716,14 @@ (send (car l) scroll-to)] [else (loop (cdr l))])))] [select (lambda (i) - (send i select #t) - (send i scroll-to))] + (cond + [i + (send i select #t) + (send i scroll-to)] + [(and (allow-deselect) selected) + (send selected show-select #f) + (set! selected #f) + (set! selected-item #f)]))] [click-select (lambda (i) (send i click-select #t) (send i scroll-to))] @@ -854,6 +874,7 @@ [selected #f] [selected-item #f]) (sequence + (send top-buffer set-transparent (member 'transparent style)) (super-init parent top-buffer style) (allow-tab-exit #t) (send top-buffer set-cursor arrow-cursor) diff --git a/collects/mrlib/image-core.ss b/collects/mrlib/image-core.ss index ceee10e07c..51444167b6 100644 --- a/collects/mrlib/image-core.ss +++ b/collects/mrlib/image-core.ss @@ -1,5 +1,4 @@ #lang scheme/base - #| This library is the part of the 2htdp/image @@ -157,12 +156,12 @@ has been moved out). (define-struct/reg-mk curve-segment (start s-angle s-pull end e-angle e-pull color) #:transparent #:omit-define-syntaxes) ;; a normalized-shape (subtype of shape) is either -;; - (make-overlay normalized-shape cropped-simple-shape) -;; - cropped-simple-shape +;; - (make-overlay normalized-shape cn-or-simple-shape) +;; - cn-or-simple-shape -;; a cropped-simple-shape is either -;; - (make-crop (listof points) cropped-simple-shape) +;; an cn-or-simple-shape is either: ;; - simple-shape +;; - (make-crop (listof points) normalized-shape) ;; a simple-shape (subtype of shape) is ;; - (make-translate dx dy np-atomic-shape)) @@ -378,16 +377,10 @@ has been moved out). [dy 0] [x-scale 1] [y-scale 1] - [crops '()] ;; (listof (listof point)) [bottom #f]) (define (scale-point p) (make-point (+ dx (* x-scale (point-x p))) (+ dy (* y-scale (point-y p))))) - (define (add-crops shape) - (let loop ([crops crops]) - (cond - [(null? crops) shape] - [else (make-crop (car crops) (loop (cdr crops)))]))) (cond [(translate? shape) (loop (translate-shape shape) @@ -395,7 +388,6 @@ has been moved out). (+ dy (* y-scale (translate-dy shape))) x-scale y-scale - crops bottom)] [(scale? shape) (loop (scale-shape shape) @@ -403,34 +395,36 @@ has been moved out). dy (* x-scale (scale-x shape)) (* y-scale (scale-y shape)) - crops bottom)] [(overlay? shape) (loop (overlay-bottom shape) - dx dy x-scale y-scale crops + dx dy x-scale y-scale (loop (overlay-top shape) - dx dy x-scale y-scale crops + dx dy x-scale y-scale bottom))] [(crop? shape) - (loop (crop-shape shape) - dx dy x-scale y-scale - (cons (map scale-point (crop-points shape)) crops) - bottom)] + (let* ([inside (loop (crop-shape shape) + dx dy x-scale y-scale + #f)] + [this-one + (make-crop (map scale-point (crop-points shape)) + inside)]) + (if bottom + (make-overlay bottom this-one) + this-one))] [(polygon? shape) (let* ([this-one - (add-crops - (make-polygon (map scale-point (polygon-points shape)) - (polygon-mode shape) - (scale-color (polygon-color shape) x-scale y-scale)))]) + (make-polygon (map scale-point (polygon-points shape)) + (polygon-mode shape) + (scale-color (polygon-color shape) x-scale y-scale))]) (if bottom (make-overlay bottom (f this-one)) (f this-one)))] [(line-segment? shape) (let ([this-one - (add-crops - (make-line-segment (scale-point (line-segment-start shape)) - (scale-point (line-segment-end shape)) - (scale-color (line-segment-color shape) x-scale y-scale)))]) + (make-line-segment (scale-point (line-segment-start shape)) + (scale-point (line-segment-end shape)) + (scale-color (line-segment-color shape) x-scale y-scale))]) (if bottom (make-overlay bottom (f this-one)) (f this-one)))] @@ -439,27 +433,40 @@ has been moved out). ;; between the two points when it is drawn, ;; so we don't need to scale it here (let ([this-one - (add-crops - (make-curve-segment (scale-point (curve-segment-start shape)) - (curve-segment-s-angle shape) - (curve-segment-s-pull shape) - (scale-point (curve-segment-end shape)) - (curve-segment-e-angle shape) - (curve-segment-e-pull shape) - (scale-color (curve-segment-color shape) x-scale y-scale)))]) + (make-curve-segment (scale-point (curve-segment-start shape)) + (curve-segment-s-angle shape) + (curve-segment-s-pull shape) + (scale-point (curve-segment-end shape)) + (curve-segment-e-angle shape) + (curve-segment-e-pull shape) + (scale-color (curve-segment-color shape) x-scale y-scale))]) (if bottom (make-overlay bottom (f this-one)) (f this-one)))] [(np-atomic-shape? shape) (let ([this-one - (add-crops - (make-translate dx dy (scale-np-atomic x-scale y-scale shape)))]) + (make-translate dx dy (scale-np-atomic x-scale y-scale shape))]) (if bottom (make-overlay bottom (f this-one)) (f this-one)))] [else (error 'normalize-shape "unknown shape ~s\n" shape)]))) +(define (normalized-shape? s) + (cond + [(overlay? s) + (and (normalized-shape? (overlay-top s)) + (cn-or-simple-shape? (overlay-bottom s)))] + [else + (cn-or-simple-shape? s)])) + +(define (cn-or-simple-shape? s) + (cond + [(crop? s) + (normalized-shape? (crop-shape s))] + [else + (simple-shape? s)])) + (define (simple-shape? shape) (or (and (translate? shape) (np-atomic-shape? (translate-shape shape))) @@ -555,22 +562,30 @@ has been moved out). (define (render-normalized-shape shape dc dx dy) (cond [(overlay? shape) - (render-cropped-simple-shape (overlay-bottom shape) dc dx dy) + (render-cn-or-simple-shape (overlay-bottom shape) dc dx dy) (render-normalized-shape (overlay-top shape) dc dx dy)] [else - (render-cropped-simple-shape shape dc dx dy)])) + (render-cn-or-simple-shape shape dc dx dy)])) -(define (render-cropped-simple-shape shape dc dx dy) +(define last-cropped-points (make-parameter #f)) + +(define (render-cn-or-simple-shape shape dc dx dy) (cond [(crop? shape) - (let ([old-region (send dc get-clipping-region)] - [new-region (new region% [dc dc])] - [path (polygon-points->path (crop-points shape))]) - (send new-region set-path path dx dy) - (when old-region (send new-region intersect old-region)) - (send dc set-clipping-region new-region) - (render-cropped-simple-shape (crop-shape shape) dc dx dy) - (send dc set-clipping-region old-region))] + (let ([points (crop-points shape)]) + (cond + [(equal? points (last-cropped-points)) + (render-normalized-shape (crop-shape shape) dc dx dy)] + [else + (let ([old-region (send dc get-clipping-region)] + [new-region (new region% [dc dc])] + [path (polygon-points->path points)]) + (send new-region set-path path dx dy) + (when old-region (send new-region intersect old-region)) + (send dc set-clipping-region new-region) + (parameterize ([last-cropped-points points]) + (render-normalized-shape (crop-shape shape) dc dx dy)) + (send dc set-clipping-region old-region))]))] [else (render-simple-shape shape dc dx dy)])) @@ -932,4 +947,4 @@ the mask bitmap and the original bitmap are all together in a single bytes! ;; method names (provide get-shape get-bb get-normalized? get-normalized-shape) -(provide np-atomic-shape? atomic-shape? simple-shape?) +(provide np-atomic-shape? atomic-shape? simple-shape? cn-or-simple-shape? normalized-shape?) diff --git a/collects/mrlib/scribblings/hierlist/list.scrbl b/collects/mrlib/scribblings/hierlist/list.scrbl index de9b6b0a3e..81a7b21562 100644 --- a/collects/mrlib/scribblings/hierlist/list.scrbl +++ b/collects/mrlib/scribblings/hierlist/list.scrbl @@ -16,7 +16,15 @@ Creates a hierarchical-list control. 'resize-corner 'deleted 'transparent)) '(no-hscroll)])]{ -Creates the control.} +Creates the control. + +If the style @scheme['transparent] is passed, then the +@method[editor-snip% use-style-background] method will be +called with @scheme[#t] when editor snips are created as part of +the hierarchical list, ensuring that the entire control is +transparent. + +} @defmethod[(get-selected) (or/c (is-a?/c hierarchical-list-item<%>) diff --git a/collects/r5rs/main.ss b/collects/r5rs/main.ss index 6e48ff2b52..6fe8f966fd 100644 --- a/collects/r5rs/main.ss +++ b/collects/r5rs/main.ss @@ -209,7 +209,9 @@ form)] [((unquote-splicing e) . rest) (if (zero? depth) - #`(mappend e #,(loop #'rest depth)) + (if (null? (syntax-e #'rest)) + #'e ;; Note: we're not check for a list + #`(mappend e #,(loop #'rest depth))) #`(mcons (mcons 'unquote-splicing #,(loop #'(e) (sub1 depth))) #,(loop #'rest depth)))] diff --git a/collects/redex/pict.ss b/collects/redex/pict.ss index c511e1f375..0d636a934f 100644 --- a/collects/redex/pict.ss +++ b/collects/redex/pict.ss @@ -59,6 +59,7 @@ [default-style (parameter/c text-style/c)] [non-terminal-style (parameter/c text-style/c)] [non-terminal-subscript-style (parameter/c text-style/c)] + [non-terminal-superscript-style (parameter/c text-style/c)] [linebreaks (parameter/c (or/c false/c (listof boolean?)))] [curly-quotes-for-strings (parameter/c boolean?)] [white-bracket-sizing (parameter/c diff --git a/collects/redex/private/core-layout.ss b/collects/redex/private/core-layout.ss index c2e8fad505..138b15ba67 100644 --- a/collects/redex/private/core-layout.ss +++ b/collects/redex/private/core-layout.ss @@ -6,7 +6,8 @@ texpict/utils texpict/mrpict - + + scheme/match scheme/gui/base scheme/class) @@ -21,6 +22,7 @@ label-style non-terminal-style non-terminal-subscript-style + non-terminal-superscript-style label-font-size default-font-size metafunction-font-size @@ -688,18 +690,15 @@ 'modern (default-font-size)))))] [(and (symbol? atom) - (regexp-match #rx"^([^_]*)_(.*)$" (symbol->string atom))) + (regexp-match #rx"^([^_^]*)_([^^]*)\\^?(.*)$" (symbol->string atom))) => - (λ (m) - (let* ([first-part (cadr m)] - [second-part (caddr m)] - [first-span (- span (string-length first-part))]) - (list - (non-terminal->token col first-span first-part) - (make-string-token (+ col first-span) - (- span first-span) - second-part - (non-terminal-subscript-style)))))] + (match-lambda + [(list _ nt sub sup) + (let* ([sub-pict (basic-text sub (non-terminal-subscript-style))] + [sup-pict (basic-text sup (non-terminal-superscript-style))] + [sub+sup (lbl-superimpose sub-pict sup-pict)]) + (list (non-terminal->token col span nt) + (make-pict-token (+ col span) 0 sub+sup)))])] [(or (memq atom all-nts) (memq atom '(number variable variable-except variable-not-otherwise-mentioned))) (list (non-terminal->token col span (format "~s" atom)))] @@ -747,6 +746,7 @@ (define (unksc str) (pink-background ((current-text) str 'modern (default-font-size)))) (define non-terminal-style (make-parameter '(italic . roman))) (define non-terminal-subscript-style (make-parameter `(subscript . ,(non-terminal-style)))) + (define non-terminal-superscript-style (make-parameter `(superscript . ,(non-terminal-style)))) (define default-style (make-parameter 'roman)) (define metafunction-style (make-parameter 'swiss)) (define (metafunction-text str) ((current-text) str (metafunction-style) (metafunction-font-size))) diff --git a/collects/redex/private/rg.ss b/collects/redex/private/rg.ss index 573c7cecfb..b9817cf770 100644 --- a/collects/redex/private/rg.ss +++ b/collects/redex/private/rg.ss @@ -14,9 +14,6 @@ (define (exotic-choice? [random random]) (= 0 (random 5))) (define (use-lang-literal? [random random]) (= 0 (random 20))) -(define (preferred-production? attempt [random random]) - (and (>= attempt preferred-production-threshold) - (zero? (random 2)))) (define default-check-attempts 1000) @@ -57,27 +54,8 @@ (define (pick-string lang-lits attempt [random random]) (random-string lang-lits (random-natural 1/5 random) attempt random)) -(define (pick-nt name cross? lang attempt pref-prods - [random random] - [pref-prod? preferred-production?]) - (let ([prods (nt-rhs (nt-by-name lang name cross?))]) - (cond [(and pref-prods (pref-prod? attempt random)) - (hash-ref - ((if cross? pref-prods-cross pref-prods-non-cross) - pref-prods) - name)] - [else prods]))) - -(define-struct pref-prods (cross non-cross)) - -(define (pick-preferred-productions lang) - (let ([pick (λ (sel) - (for/hash ([nt (sel lang)]) - (values (nt-name nt) - (list (pick-from-list (nt-rhs nt))))))]) - (make-pref-prods - (pick compiled-lang-cclang) - (pick compiled-lang-lang)))) +(define (pick-nts name cross? lang attempt) + (nt-rhs (nt-by-name lang name cross?))) (define (pick-from-list l [random random]) (list-ref l (random (length l)))) @@ -118,9 +96,6 @@ (define proportion-at-size 1/10) (define post-threshold-incr 50) -(define preferred-production-threshold - (+ retry-threshold 2000)) - ;; Determines the parameter p for which random-natural's expected value is E (define (expected-value->p E) ;; E = 0 => p = 1, which breaks random-natural @@ -177,11 +152,11 @@ who what attempts (if (= attempts 1) "" "s"))]) (raise (make-exn:fail:redex:generation-failure str (current-continuation-marks))))) -(define (generate lang decisions@ user-gen retries what) +(define (generate lang decisions@ what) (define-values/invoke-unit decisions@ (import) (export decisions^)) - (define ((generate-nt lang base-cases generate pref-prods) + (define ((generate-nt lang base-cases generate retries) name cross? size attempt in-hole env) (let*-values ([(term _) @@ -193,10 +168,10 @@ (min-prods (nt-by-name lang name cross?) ((if cross? base-cases-cross base-cases-non-cross) base-cases)) - ((next-non-terminal-decision) name cross? lang attempt pref-prods)))]) + ((next-non-terminal-decision) name cross? lang attempt)))]) (generate (max 0 (sub1 size)) attempt empty-env in-hole (rhs-pattern rhs)))) (λ (_ env) (mismatches-satisfied? env)) - size attempt)]) + size attempt retries)]) term)) (define (generate-sequence ellipsis generate env length) @@ -222,18 +197,18 @@ (values (cons term terms) (cons env envs)))))]) (values seq (merge-environments envs)))) - (define (generate/pred name gen pred init-sz init-att) + (define (generate/pred name gen pred init-sz init-att retries) (let ([pre-threshold-incr (ceiling (/ (- retry-threshold init-att) - (* proportion-before-threshold retries)))] + (* proportion-before-threshold (add1 retries))))] [incr-size? (λ (remain) (zero? (modulo (sub1 remain) (ceiling (* proportion-at-size retries)))))]) - (let retry ([remaining retries] + (let retry ([remaining (add1 retries)] [size init-sz] [attempt init-att]) (if (zero? remaining) @@ -279,120 +254,109 @@ (cons (make-bind (binder-name key) val) bindings) bindings)))) - (define (generate-pat lang sexp pref-prods user-gen user-acc size attempt env in-hole pat) - (define recur (curry generate-pat lang sexp pref-prods user-gen user-acc size attempt)) + (define (generate-pat lang sexp retries size attempt env in-hole pat) + (define recur (curry generate-pat lang sexp retries size attempt)) (define recur/pat (recur env in-hole)) (define ((recur/pat/size-attempt pat) size attempt) - (generate-pat lang sexp pref-prods user-gen user-acc size attempt env in-hole pat)) + (generate-pat lang sexp retries size attempt env in-hole pat)) (define clang (rg-lang-clang lang)) (define gen-nt (generate-nt clang (rg-lang-base-cases lang) - (curry generate-pat lang sexp pref-prods user-gen user-acc) - pref-prods)) + (curry generate-pat lang sexp retries) + retries)) - (define (default-gen user-acc) - (match pat - [`number (values ((next-number-decision) attempt) env)] - [`natural (values ((next-natural-decision) attempt) env)] - [`integer (values ((next-integer-decision) attempt) env)] - [`real (values ((next-real-decision) attempt) env)] - [`(variable-except ,vars ...) - (generate/pred 'variable - (recur/pat/size-attempt 'variable) - (λ (var _) (not (memq var vars))) - size attempt)] - [`variable - (values ((next-variable-decision) (rg-lang-lits lang) attempt) - env)] - [`variable-not-otherwise-mentioned - (generate/pred 'variable - (recur/pat/size-attempt 'variable) - (λ (var _) (not (memq var (compiled-lang-literals clang)))) - size attempt)] - [`(variable-prefix ,prefix) - (define (symbol-append prefix suffix) - (string->symbol (string-append (symbol->string prefix) (symbol->string suffix)))) - (let-values ([(term env) (recur/pat 'variable)]) - (values (symbol-append prefix term) env))] - [`string - (values ((next-string-decision) (rg-lang-lits lang) attempt) - env)] - [`(side-condition ,pat ,(? procedure? condition) ,guard-src-loc) - (generate/pred `(side-condition ,(unparse-pattern pat) ,guard-src-loc) - (recur/pat/size-attempt pat) - (λ (_ env) (condition (bindings env))) - size attempt)] - [`(name ,(? symbol? id) ,p) - (let-values ([(term env) (recur/pat p)]) - (values term (hash-set env (make-binder id) term)))] - [`hole (values in-hole env)] - [`(in-hole ,context ,contractum) - (let-values ([(term env) (recur/pat contractum)]) - (recur env term context))] - [`(hide-hole ,pattern) (recur env the-hole pattern)] - [`any - (let*-values ([(new-lang nt) ((next-any-decision) lang sexp)] - ; Don't use preferred productions for the sexp language. - [(pref-prods) (if (eq? new-lang lang) pref-prods #f)] - [(term _) (generate-pat new-lang - sexp - pref-prods - user-gen - user-acc - size - attempt - empty-env - the-hole - nt)]) - (values term env))] - [(? (is-nt? clang)) - (values (gen-nt pat #f size attempt in-hole env) env)] - [(struct binder ((or (? (is-nt? clang) nt) - (app (symbol-match named-nt-rx) (? (is-nt? clang) nt))))) - (generate/prior pat env (λ () (recur/pat nt)))] - [(struct binder ((or (? built-in? b) - (app (symbol-match named-nt-rx) (? built-in? b))))) - (generate/prior pat env (λ () (recur/pat b)))] - [(struct mismatch (name (app (symbol-match mismatch-nt-rx) - (? symbol? (? (is-nt? clang) nt))))) - (let-values ([(term _) (recur/pat nt)]) - (values term (hash-set env pat term)))] - [(struct mismatch (name (app (symbol-match mismatch-nt-rx) - (? symbol? (? built-in? b))))) - (let-values ([(term _) (recur/pat b)]) - (values term (hash-set env pat term)))] - [`(cross ,(? symbol? cross-nt)) - (values (gen-nt cross-nt #t size attempt in-hole env) env)] - [(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) (values pat env)] - [(list-rest (and (struct ellipsis (name sub-pat class vars)) ellipsis) rest) - (let*-values ([(length) (let ([prior (hash-ref env class #f)]) - (if prior prior ((next-sequence-decision) attempt)))] - [(seq env) (generate-sequence ellipsis recur env length)] - [(rest env) (recur (hash-set (hash-set env class length) name length) - in-hole rest)]) - (values (append seq rest) env))] - [(list-rest pat rest) - (let*-values - ([(pat-term env) (recur/pat pat)] - [(rest-term env) (recur env in-hole rest)]) - (values (cons pat-term rest-term) env))] - [else - (error what "unknown pattern ~s\n" pat)])) - - (user-gen - pat size in-hole user-acc env attempt - (λ (pat #:size [size size] #:contractum [in-hole in-hole] #:acc [user-acc user-acc] #:env [env env]) - (generate-pat lang sexp pref-prods user-gen user-acc size attempt env in-hole pat)) - default-gen)) + (match pat + [`number (values ((next-number-decision) attempt) env)] + [`natural (values ((next-natural-decision) attempt) env)] + [`integer (values ((next-integer-decision) attempt) env)] + [`real (values ((next-real-decision) attempt) env)] + [`(variable-except ,vars ...) + (generate/pred 'variable + (recur/pat/size-attempt 'variable) + (λ (var _) (not (memq var vars))) + size attempt retries)] + [`variable + (values ((next-variable-decision) (rg-lang-lits lang) attempt) + env)] + [`variable-not-otherwise-mentioned + (generate/pred 'variable + (recur/pat/size-attempt 'variable) + (λ (var _) (not (memq var (compiled-lang-literals clang)))) + size attempt retries)] + [`(variable-prefix ,prefix) + (define (symbol-append prefix suffix) + (string->symbol (string-append (symbol->string prefix) (symbol->string suffix)))) + (let-values ([(term env) (recur/pat 'variable)]) + (values (symbol-append prefix term) env))] + [`string + (values ((next-string-decision) (rg-lang-lits lang) attempt) + env)] + [`(side-condition ,pat ,(? procedure? condition) ,guard-src-loc) + (generate/pred `(side-condition ,(unparse-pattern pat) ,guard-src-loc) + (recur/pat/size-attempt pat) + (λ (_ env) (condition (bindings env))) + size attempt retries)] + [`(name ,(? symbol? id) ,p) + (let-values ([(term env) (recur/pat p)]) + (values term (hash-set env (make-binder id) term)))] + [`hole (values in-hole env)] + [`(in-hole ,context ,contractum) + (let-values ([(term env) (recur/pat contractum)]) + (recur env term context))] + [`(hide-hole ,pattern) (recur env the-hole pattern)] + [`any + (let*-values ([(new-lang nt) ((next-any-decision) lang sexp)] + [(term _) (generate-pat new-lang + sexp + retries + size + attempt + empty-env + the-hole + nt)]) + (values term env))] + [(? (is-nt? clang)) + (values (gen-nt pat #f size attempt in-hole env) env)] + [(struct binder ((or (? (is-nt? clang) nt) + (app (symbol-match named-nt-rx) (? (is-nt? clang) nt))))) + (generate/prior pat env (λ () (recur/pat nt)))] + [(struct binder ((or (? built-in? b) + (app (symbol-match named-nt-rx) (? built-in? b))))) + (generate/prior pat env (λ () (recur/pat b)))] + [(struct mismatch (name (app (symbol-match mismatch-nt-rx) + (? symbol? (? (is-nt? clang) nt))))) + (let-values ([(term _) (recur/pat nt)]) + (values term (hash-set env pat term)))] + [(struct mismatch (name (app (symbol-match mismatch-nt-rx) + (? symbol? (? built-in? b))))) + (let-values ([(term _) (recur/pat b)]) + (values term (hash-set env pat term)))] + [`(cross ,(? symbol? cross-nt)) + (values (gen-nt cross-nt #t size attempt in-hole env) env)] + [(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) (values pat env)] + [(list-rest (and (struct ellipsis (name sub-pat class vars)) ellipsis) rest) + (let*-values ([(length) (let ([prior (hash-ref env class #f)]) + (if prior prior ((next-sequence-decision) attempt)))] + [(seq env) (generate-sequence ellipsis recur env length)] + [(rest env) (recur (hash-set (hash-set env class length) name length) + in-hole rest)]) + (values (append seq rest) env))] + [(list-rest pat rest) + (let*-values + ([(pat-term env) (recur/pat pat)] + [(rest-term env) (recur env in-hole rest)]) + (values (cons pat-term rest-term) env))] + [else + (error what "unknown pattern ~s\n" pat)])) (let ([rg-lang (prepare-lang lang)] [rg-sexp (prepare-lang sexp)]) (λ (pat) (let ([parsed (reassign-classes (parse-pattern pat lang 'top-level))]) - (λ (size attempt) + (λ (size attempt retries) (let-values ([(term env) (generate/pred pat @@ -400,16 +364,14 @@ (generate-pat rg-lang rg-sexp - ((next-pref-prods-decision) (rg-lang-clang rg-lang)) - user-gen - #f + retries size attempt empty-env the-hole parsed)) (λ (_ env) (mismatches-satisfied? env)) - size attempt)]) + size attempt retries)]) (values term (bindings env)))))))) (define-struct base-cases (cross non-cross)) @@ -681,36 +643,35 @@ x (raise-type-error 'redex-check "reduction-relation" x))) -(define (defer-all pat size in-hole acc env att recur defer) - (defer acc)) - -(define-for-syntax (term-generator lang pat decisions@ custom retries what) +(define-for-syntax (term-generator lang pat decisions@ what) (with-syntax ([pattern (rewrite-side-conditions/check-errs (language-id-nts lang what) what #t pat)]) - #`((generate #,lang #,decisions@ #,custom #,retries '#,what) `pattern))) + #`((generate #,lang #,decisions@ '#,what) `pattern))) (define-syntax (generate-term stx) (syntax-case stx () - [(_ lang pat size . kw-args) - (with-syntax ([(attempt retries custom) - (parse-kw-args `((#:attempt . 1) - (#:retries . ,#'default-retries) - (#:custom . ,#'defer-all)) + [(name lang pat size . kw-args) + (with-syntax ([(attempt retries) + (parse-kw-args `((#:attempt-num . 1) + (#:retries . ,#'default-retries)) (syntax kw-args) stx)]) - (with-syntax ([generate (term-generator #'lang - #'pat - #'(generation-decisions) - #'custom - #'retries - 'generate-term)]) - (syntax/loc stx - (let-values ([(term _) (generate size attempt)]) - term))))] - [(_ lang pat size) - (syntax/loc stx (generate-term lang pat size #:attempt 1))])) + (syntax/loc stx + ((generate-term lang pat) size #:attempt-num attempt #:retries retries)))] + [(name lang pat) + (with-syntax ([make-gen (term-generator #'lang + #'pat + #'(generation-decisions) + (syntax-e #'name))]) + (syntax/loc stx + (let ([generate make-gen]) + (λ (size #:attempt-num [attempt-num 1] #:retries [retries default-retries]) + (let ([att (assert-nat 'name attempt-num)] + [ret (assert-nat 'name retries)]) + (let-values ([(term _) (generate size att ret)]) + term))))))])) (define-for-syntax (show-message stx) (syntax-case stx () @@ -734,12 +695,12 @@ (let-values ([(names names/ellipses) (extract-names (language-id-nts #'lang 'redex-check) 'redex-check #t #'pat)] - [(attempts-stx source-stx retries-stx custom-stx) + [(attempts-stx source-stx retries-stx print?-stx) (apply values (parse-kw-args `((#:attempts . ,#'default-check-attempts) (#:source . #f) (#:retries . ,#'default-retries) - (#:custom . ,#'defer-all)) + (#:print? . #t)) (syntax kw-args) stx))]) (with-syntax ([(name ...) names] @@ -752,17 +713,7 @@ (quasisyntax/loc stx (let ([att (assert-nat 'redex-check #,attempts-stx)] [ret (assert-nat 'redex-check #,retries-stx)] - [custom (contract - (-> any/c natural-number/c any/c any/c hash? natural-number/c - (->* (any/c) - (#:size natural-number/c - #:contractum any/c - #:acc any/c - #:env hash?) - (values any/c hash?)) - (-> any/c (values any/c hash?)) - (values any/c hash?)) - #,custom-stx '+ '-)]) + [print? #,print?-stx]) (unsyntax (if source-stx #`(let-values ([(metafunc/red-rel num-cases) @@ -776,27 +727,32 @@ metafunc/red-rel property random-decisions@ - custom (max 1 (floor (/ att num-cases))) ret 'redex-check - show + (and print? show) (test-match lang pat) (λ (generated) (redex-error 'redex-check "~s does not match ~s" generated 'pat)))) #`(check-prop - #,(term-generator #'lang #'pat #'random-decisions@ #'custom #'ret 'redex-check) - property att show))) - (void))))))])) + #,(term-generator #'lang #'pat #'random-decisions@ 'redex-check) + property att ret (and print? show)))))))))])) (define (format-attempts a) (format "~a attempt~a" a (if (= 1 a) "" "s"))) -(define (check-prop generator property attempts show) - (when (check generator property attempts show) - (show (format "no counterexamples in ~a\n" - (format-attempts attempts))))) +(define (check-prop generator property attempts retries show) + (let ([c (check generator property attempts retries show)]) + (if (counterexample? c) + (unless show c) ; check printed it + (if show + (show (format "no counterexamples in ~a\n" + (format-attempts attempts))) + #t)))) -(define (check generator property attempts show +(define-struct (exn:fail:redex:test exn:fail:redex) (source term)) +(define-struct counterexample (term) #:transparent) + +(define (check generator property attempts retries show #:source [source #f] #:match [match #f] #:match-fail [match-fail #f]) @@ -804,14 +760,21 @@ (if (zero? remaining) #t (let ([attempt (add1 (- attempts remaining))]) - (let-values ([(term bindings) (generator (attempt->size attempt) attempt)]) + (let-values ([(term bindings) (generator (attempt->size attempt) attempt retries)]) (if (andmap (λ (bindings) (with-handlers ([exn:fail? (λ (exn) - (show - (format "checking ~s raises an exception\n" term)) - (raise exn))]) + (when show + (show (format "checking ~s raises an exception\n" term))) + (raise + (if show + exn + (make-exn:fail:redex:test + (format "checking ~s raises an exception:\n~a" term (exn-message exn)) + (current-continuation-marks) + exn + term))))]) (property term bindings))) (cond [(and match match-fail (match term)) => (curry map (compose make-bindings match-bindings))] @@ -819,22 +782,22 @@ [else (list bindings)])) (loop (sub1 remaining)) (begin - (show - (format "counterexample found after ~a~a:\n" - (format-attempts attempt) - (if source (format " with ~a" source) ""))) - (pretty-print term (current-output-port)) - #f))))))) + (when show + (show + (format "counterexample found after ~a~a:\n" + (format-attempts attempt) + (if source (format " with ~a" source) ""))) + (pretty-print term (current-output-port))) + (make-counterexample term)))))))) (define-syntax (check-metafunction-contract stx) (syntax-case stx () [(_ name . kw-args) (identifier? #'name) (with-syntax ([m (metafunc/err #'name stx)] - [(attempts retries custom) + [(attempts retries) (parse-kw-args `((#:attempts . ,#'default-check-attempts) - (#:retries . ,#'default-retries) - (#:custom . ,#'defer-all)) + (#:retries . ,#'default-retries)) (syntax kw-args) stx)] [show (show-message stx)]) @@ -844,18 +807,19 @@ [decisions@ (generation-decisions)] [att (assert-nat 'check-metafunction-contract attempts)]) (check-prop - ((generate lang decisions@ custom retries 'check-metafunction-contract) + ((generate lang decisions@ 'check-metafunction-contract) (if dom dom '(any (... ...)))) (λ (t _) (with-handlers ([exn:fail:redex? (λ (_) #f)]) (begin (term (name ,@t)) #t))) att + retries show))))])) -(define (check-lhs-pats lang mf/rr prop decisions@ custom attempts retries what show - [match #f] - [match-fail #f]) - (let ([lang-gen (generate lang decisions@ custom retries what)]) +(define (check-lhs-pats lang mf/rr prop decisions@ attempts retries what show + [match #f] + [match-fail #f]) + (let ([lang-gen (generate lang decisions@ what)]) (let-values ([(pats srcs) (cond [(metafunc-proc? mf/rr) (values (map metafunc-case-lhs-pat (metafunc-proc-cases mf/rr)) @@ -863,47 +827,53 @@ [(reduction-relation? mf/rr) (values (map (λ (rwp) ((rewrite-proc-lhs rwp) lang)) (reduction-relation-make-procs mf/rr)) (reduction-relation-srcs mf/rr))])]) - (when (for/and ([pat pats] [src srcs]) - (with-handlers ([exn:fail:redex:generation-failure? - ; Produce an error message that blames the LHS as a whole. - (λ (_) - (raise-gen-fail what (format "LHS of ~a" src) retries))]) - (check - (lang-gen pat) - prop - attempts - show - #:source src - #:match match - #:match-fail match-fail))) - (show - (format "no counterexamples in ~a (with each clause)\n" - (format-attempts attempts))))))) + (let loop ([pats pats] [srcs srcs]) + (if (and (null? pats) (null? srcs)) + (if show + (show + (format "no counterexamples in ~a (with each clause)\n" + (format-attempts attempts))) + #t) + (let ([c (with-handlers ([exn:fail:redex:generation-failure? + ; Produce an error message that blames the LHS as a whole. + (λ (_) + (raise-gen-fail what (format "LHS of ~a" (car srcs)) retries))]) + (check + (lang-gen (car pats)) + prop + attempts + retries + show + #:source (car srcs) + #:match match + #:match-fail match-fail))]) + (if (counterexample? c) + (unless show c) + (loop (cdr pats) (cdr srcs))))))))) (define-syntax (check-metafunction stx) (syntax-case stx () [(_ name property . kw-args) (with-syntax ([m (metafunc/err #'name stx)] - [(attempts retries custom) + [(attempts retries print?) (parse-kw-args `((#:attempts . , #'default-check-attempts) (#:retries . ,#'default-retries) - (#:custm . ,#'defer-all)) + (#:print? . #t)) (syntax kw-args) - stx)] - [show (show-message stx)]) - (syntax/loc stx - (let ([att (assert-nat 'check-metafunction attempts)] - [ret (assert-nat 'check-metafunction retries)]) - (check-lhs-pats - (metafunc-proc-lang m) - m - (λ (term _) (property term)) - (generation-decisions) - custom - att - ret - 'check-metafunction - show))))])) + stx)]) + (with-syntax ([show (show-message stx)]) + (syntax/loc stx + (let ([att (assert-nat 'check-metafunction attempts)] + [ret (assert-nat 'check-metafunction retries)]) + (check-lhs-pats + (metafunc-proc-lang m) + m + (λ (term _) (property term)) + (generation-decisions) + att + ret + 'check-metafunction + (and print? show))))))])) (define (reduction-relation-srcs r) (map (λ (proc) (or (rewrite-proc-name proc) @@ -917,11 +887,11 @@ (define-syntax (check-reduction-relation stx) (syntax-case stx () [(_ relation property . kw-args) - (with-syntax ([(attempts retries decisions@ custom) + (with-syntax ([(attempts retries decisions@ print?) (parse-kw-args `((#:attempts . , #'default-check-attempts) (#:retries . ,#'default-retries) (#:decisions . ,#'random-decisions@) - (#:custom . ,#'defer-all)) + (#:print? . #t)) (syntax kw-args) stx)] [show (show-message stx)]) @@ -934,11 +904,10 @@ rel (λ (term _) (property term)) decisions@ - custom attempts retries 'check-reduction-relation - show))))])) + (and print? show)))))])) (define-signature decisions^ (next-variable-decision @@ -949,8 +918,7 @@ next-non-terminal-decision next-sequence-decision next-any-decision - next-string-decision - next-pref-prods-decision)) + next-string-decision)) (define random-decisions@ (unit (import) (export decisions^) @@ -959,11 +927,10 @@ (define (next-natural-decision) pick-natural) (define (next-integer-decision) pick-integer) (define (next-real-decision) pick-real) - (define (next-non-terminal-decision) pick-nt) + (define (next-non-terminal-decision) pick-nts) (define (next-sequence-decision) pick-sequence-length) (define (next-any-decision) pick-any) - (define (next-string-decision) pick-string) - (define (next-pref-prods-decision) pick-preferred-productions))) + (define (next-string-decision) pick-string))) (define generation-decisions (make-parameter random-decisions@)) @@ -979,18 +946,17 @@ (struct-out class) (struct-out binder) (struct-out base-cases) - (struct-out pref-prods)) + (struct-out counterexample) + (struct-out exn:fail:redex:test)) -(provide pick-from-list pick-sequence-length - pick-char pick-var pick-string - pick-nt pick-any pick-preferred-productions +(provide pick-from-list pick-sequence-length pick-nts + pick-char pick-var pick-string pick-any pick-number pick-natural pick-integer pick-real parse-pattern unparse-pattern parse-language prepare-lang class-reassignments reassign-classes default-retries proportion-at-size - preferred-production-threshold retry-threshold - proportion-before-threshold post-threshold-incr + retry-threshold proportion-before-threshold post-threshold-incr is-nt? nt-by-name min-prods generation-decisions decisions^ random-string diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl index fb34a26e47..7fc37e9828 100644 --- a/collects/redex/redex.scrbl +++ b/collects/redex/redex.scrbl @@ -1127,30 +1127,37 @@ metafunctions or unnamed reduction-relation cases) to application counts.} (values (covered-cases equals-coverage) (covered-cases plus-coverage))))] -@defform/subs[(generate-term language @#,ttpattern size-exp kw-args ...) - ([kw-args (code:line #:attempts attempts-expr) +@defform*/subs[[(generate-term language @#,ttpattern size-expr kw-args ...) + (generate-term language @#,ttpattern)] + ([kw-args (code:line #:attempt-num attempts-expr) (code:line #:retries retries-expr)]) #:contracts ([size-expr natural-number/c] [attempt-num-expr natural-number/c] [retries-expr natural-number/c])]{ -Generates a random term matching @scheme[pattern] (in the given language). + +In its first form, @scheme[generate-term] produces a random term matching +the given pattern (according to the given language). In its second, +@scheme[generate-term] produces a procedure for constructing the same. +This procedure expects @scheme[size-expr] (below) as its sole positional +argument and allows the same optional keyword arguments as the first form. +The second form may be more efficient when generating many terms. The argument @scheme[size-expr] bounds the height of the generated term -(measured as the height of the derivation tree used to produce -the term). +(measured as the height of its parse tree). The optional keyword argument @scheme[attempt-num-expr] (default @scheme[1]) provides coarse grained control over the random -decisions made during generation. For example, the expected length of -@pattech[pattern-sequence]s increases with @scheme[attempt-num-expr]. +decisions made during generation; increasing @scheme[attempt-num-expr] +tends to increase the complexity of the result. For example, the expected +length of @pattech[pattern-sequence]s increases with @scheme[attempt-num-expr]. The random generation process does not actively consider the constraints -imposed by @pattech[side-condition] or @tt{_!_} @|pattern|s when -constructing a term; instead, it tests the satisfaction of -such constraints after it freely generates the relevant portion of the -sub-term---regenerating the sub-term if necessary. The optional keyword -argument @scheme[retries-expr] (default @scheme[100]) bounds the number of times that -@scheme[generate-term] retries the generation of any sub-term. If +imposed by @pattech[side-condition] or @tt{_!_} @|pattern|s; instead, +it uses a ``guess and check'' strategy in which it freely generates +candidate terms then tests whether they happen to satisfy the constraints, +repeating as necessary. The optional keyword argument @scheme[retries-expr] +(default @scheme[100]) bounds the number of times that +@scheme[generate-term] retries the generation of any pattern. If @scheme[generate-term] is unable to produce a satisfying term after @scheme[retries-expr] attempts, it raises an exception recognized by @scheme[exn:fail:redex:generation-failure?].} @@ -1159,11 +1166,13 @@ argument @scheme[retries-expr] (default @scheme[100]) bounds the number of times ([kw-arg (code:line #:attempts attempts-expr) (code:line #:source metafunction) (code:line #:source relation-expr) - (code:line #:retries retries-expr)]) + (code:line #:retries retries-expr) + (code:line #:print? print?-expr)]) #:contracts ([property-expr any/c] [attempts-expr natural-number/c] [relation-expr reduction-relation?] - [retries-expr natural-number/c])]{ + [retries-expr natural-number/c] + [print?-expr any/c])]{ Searches for a counterexample to @scheme[property-expr], interpreted as a predicate universally quantified over the pattern variables bound by @scheme[pattern]. @scheme[redex-check] constructs and tests @@ -1173,8 +1182,18 @@ using the @scheme[match-bindings] produced by @scheme[match]ing @math{t} against @scheme[pattern]. @scheme[redex-check] generates at most @scheme[attempts-expr] (default @scheme[1000]) -random terms in its search. The size and complexity of terms it generates -gradually increases with each failed attempt. +random terms in its search. The size and complexity of these terms increase with +each failed attempt. + +When @scheme[print?-expr] produces any non-@scheme[#f] value (the default), +@scheme[redex-check] prints the test outcome on @scheme[current-output-port]. +When @scheme[print?-expr] produces @scheme[#f], @scheme[redex-check] prints +nothing, instead +@itemlist[ + @item{returning a @scheme[counterexample] structure when the test reveals a counterexample,} + @item{returning @scheme[#t] when all tests pass, or} + @item{raising a @scheme[exn:fail:redex:test] when checking the property raises an exception.} +] When passed a metafunction or reduction relation via the optional @scheme[#:source] argument, @scheme[redex-check] distributes its attempts across the left-hand sides @@ -1221,6 +1240,16 @@ term that does not match @scheme[pattern].} #:attempts 3 #:source R))] +@defstruct[counterexample ([term any/c]) #:inspector #f]{ +Produced by @scheme[redex-check], @scheme[check-reduction-relation], and +@scheme[check-metafunction] when testing falsifies a property.} + +@defstruct[(exn:fail:redex:test exn:fail:redex) ([source exn:fail?] [term any/c])]{ +Raised by @scheme[redex-check], @scheme[check-reduction-relation], and +@scheme[check-metafunction] when testing a property raises an exception. +The @scheme[exn:fail:redex:test-source] component contains the exception raised by the property, +and the @scheme[exn:fail:redex:test-term] component contains the term that induced the exception.} + @defform/subs[(check-reduction-relation relation property kw-args ...) ([kw-arg (code:line #:attempts attempts-expr) (code:line #:retries retries-expr)]) @@ -1865,6 +1894,7 @@ cases appear. If it is a list of numbers, then only the selected cases appear (c @defparam[metafunction-style style text-style/c]{} @defparam[non-terminal-style style text-style/c]{} @defparam[non-terminal-subscript-style style text-style/c]{} +@defparam[non-terminal-superscript-style style text-style/c]{} @defparam[default-style style text-style/c]{}]]{ These parameters determine the font used for various text in @@ -1875,15 +1905,27 @@ useful things it can be is one of the symbols @scheme['roman], monospaced font, respectively. (It can also encode style information, too.) -The label-style is used for the reduction rule label -names. The literal-style is used for names that aren't +The @scheme[label-style] is used for the reduction rule label +names. The @scheme[literal-style] is used for names that aren't non-terminals that appear in patterns. The -metafunction-style is used for the names of -metafunctions. The non-terminal-style is for non-terminals -and non-terminal-subscript-style is used for the portion +@scheme[metafunction-style] is used for the names of +metafunctions. + +The @scheme[non-terminal-style] is used for the names of non-terminals. +Two parameters style the text in the (optional) "underscore" component +of a non-terminal reference. The first, @scheme[non-terminal-subscript-style], +applies to the segment between the underscore and the first caret (@scheme[^]) +to follow it; the second, @scheme[non-terminal-superscript-style], applies +to the segment following that caret. For example, in the non-terminal +reference @scheme[x_y_z], @scheme[x] has style @scheme[non-terminal-style], +@scheme[y] has style @scheme[non-terminal-subscript-style], and @scheme[z] +has style @scheme[non-terminal-superscript-style]. + +The +@scheme[non-terminal-subscript-style] is used for the portion after the underscore in non-terminal references. -The default-style is used for parenthesis, the dot in dotted +The @scheme[default-style] is used for parenthesis, the dot in dotted lists, spaces, the separator words in the grammar, the "where" and "fresh" in side-conditions, and other places where the other parameters aren't used. diff --git a/collects/redex/reduction-semantics.ss b/collects/redex/reduction-semantics.ss index fc8a9ff9d0..ad0c601b0e 100644 --- a/collects/redex/reduction-semantics.ss +++ b/collects/redex/reduction-semantics.ss @@ -50,7 +50,9 @@ check-metafunction check-metafunction-contract check-reduction-relation - exn:fail:redex:generation-failure?) + exn:fail:redex:generation-failure? + (struct-out exn:fail:redex:test) + (struct-out counterexample)) (provide/contract [current-traced-metafunctions (parameter/c (or/c 'all (listof symbol?)))] diff --git a/collects/redex/private/bitmap-test-util.ss b/collects/redex/tests/bitmap-test-util.ss similarity index 79% rename from collects/redex/private/bitmap-test-util.ss rename to collects/redex/tests/bitmap-test-util.ss index cf2dcada8d..468149ea02 100644 --- a/collects/redex/private/bitmap-test-util.ss +++ b/collects/redex/tests/bitmap-test-util.ss @@ -20,16 +20,15 @@ [(_ test-exp bitmap-filename) #`(test/proc #,(syntax-line stx) - test-exp + (λ () test-exp) bitmap-filename)])) -(define (test/proc line-number pict raw-bitmap-filename) +(define (test/proc line-number pict-thunk raw-bitmap-filename) (set! tests (+ tests 1)) - (let* ([bitmap-filename + (let* ([pict (set-fonts/call pict-thunk)] + [bitmap-filename (build-path (format "bmps-~a" (system-type)) - (case (system-type) - [(unix) (string-append "unix-" raw-bitmap-filename)] - [else raw-bitmap-filename]))] + raw-bitmap-filename)] [old-bitmap (if (file-exists? bitmap-filename) (make-object bitmap% bitmap-filename) (let* ([bm (make-object bitmap% 100 20)] @@ -39,8 +38,8 @@ (send bdc set-bitmap #f) bm))] [new-bitmap (make-object bitmap% - (inexact->exact (pict-width pict)) - (inexact->exact (pict-height pict)))] + (ceiling (inexact->exact (pict-width pict))) + (ceiling (inexact->exact (pict-height pict))))] [bdc (make-object bitmap-dc% new-bitmap)]) (send bdc clear) (draw-pict pict bdc 0 0) @@ -50,6 +49,33 @@ (let ([failed-panel (make-failed-panel line-number bitmap-filename old-bitmap new-bitmap diff-bitmap)]) (set! failed (append failed (list failed-panel)))))))) +(define (set-fonts/call thunk) + (case (system-type) + [(unix) + (let ([rewrite-style + (λ (s) + (let loop ([s s]) + (cond + [(pair? s) (cons (loop (car s)) (loop (cdr s)))] + [(eq? s 'roman) (verify-face " DejaVu Serif")] + [(eq? s 'swiss) (verify-face " DejaVu Sans")] + [else s])))]) + (parameterize ([label-style (rewrite-style (label-style))] + [literal-style (rewrite-style (literal-style))] + [metafunction-style (rewrite-style (metafunction-style))] + [non-terminal-style (rewrite-style (non-terminal-style))] + [non-terminal-subscript-style (rewrite-style (non-terminal-subscript-style))] + [non-terminal-superscript-style (rewrite-style (non-terminal-superscript-style))] + [default-style (rewrite-style (default-style))]) + (thunk)))] + [else + (thunk)])) + +(define (verify-face face) + (unless (member face (get-face-list)) + (error 'verify-face "unknown face: ~s" face)) + face) + (define (compute-diffs old-bitmap new-bitmap) (let* ([w (max (send old-bitmap get-width) (send new-bitmap get-width))] diff --git a/collects/redex/private/bitmap-test.ss b/collects/redex/tests/bitmap-test.ss similarity index 97% rename from collects/redex/private/bitmap-test.ss rename to collects/redex/tests/bitmap-test.ss index 8a8aefe9c7..e5f73397d9 100644 --- a/collects/redex/private/bitmap-test.ss +++ b/collects/redex/tests/bitmap-test.ss @@ -159,5 +159,9 @@ ;; make sure two metafunctions simultaneously rewritten line up properly (test (render-metafunctions S T TL) "metafunctions-multiple.png") +;; Non-terminal superscripts +(test (render-lw lang (to-lw (x_^abcdef x_q^abcdef))) + "superscripts.png") + (printf "bitmap-test.ss: ") (done) diff --git a/collects/redex/private/bmps-macosx/extended-language.png b/collects/redex/tests/bmps-macosx/extended-language.png similarity index 100% rename from collects/redex/private/bmps-macosx/extended-language.png rename to collects/redex/tests/bmps-macosx/extended-language.png diff --git a/collects/redex/private/bmps-macosx/extended-reduction-relation.png b/collects/redex/tests/bmps-macosx/extended-reduction-relation.png similarity index 100% rename from collects/redex/private/bmps-macosx/extended-reduction-relation.png rename to collects/redex/tests/bmps-macosx/extended-reduction-relation.png diff --git a/collects/redex/private/bmps-macosx/language-nox.png b/collects/redex/tests/bmps-macosx/language-nox.png similarity index 100% rename from collects/redex/private/bmps-macosx/language-nox.png rename to collects/redex/tests/bmps-macosx/language-nox.png diff --git a/collects/redex/private/bmps-macosx/language.png b/collects/redex/tests/bmps-macosx/language.png similarity index 100% rename from collects/redex/private/bmps-macosx/language.png rename to collects/redex/tests/bmps-macosx/language.png diff --git a/collects/redex/private/bmps-macosx/lw.png b/collects/redex/tests/bmps-macosx/lw.png similarity index 100% rename from collects/redex/private/bmps-macosx/lw.png rename to collects/redex/tests/bmps-macosx/lw.png diff --git a/collects/redex/private/bmps-macosx/metafunction-Name-vertical.png b/collects/redex/tests/bmps-macosx/metafunction-Name-vertical.png similarity index 100% rename from collects/redex/private/bmps-macosx/metafunction-Name-vertical.png rename to collects/redex/tests/bmps-macosx/metafunction-Name-vertical.png diff --git a/collects/redex/private/bmps-macosx/metafunction-Name.png b/collects/redex/tests/bmps-macosx/metafunction-Name.png similarity index 100% rename from collects/redex/private/bmps-macosx/metafunction-Name.png rename to collects/redex/tests/bmps-macosx/metafunction-Name.png diff --git a/collects/redex/private/bmps-macosx/metafunction-T.png b/collects/redex/tests/bmps-macosx/metafunction-T.png similarity index 100% rename from collects/redex/private/bmps-macosx/metafunction-T.png rename to collects/redex/tests/bmps-macosx/metafunction-T.png diff --git a/collects/redex/private/bmps-macosx/metafunction-TL.png b/collects/redex/tests/bmps-macosx/metafunction-TL.png similarity index 100% rename from collects/redex/private/bmps-macosx/metafunction-TL.png rename to collects/redex/tests/bmps-macosx/metafunction-TL.png diff --git a/collects/redex/private/bmps-macosx/metafunction-multi-arg.png b/collects/redex/tests/bmps-macosx/metafunction-multi-arg.png similarity index 100% rename from collects/redex/private/bmps-macosx/metafunction-multi-arg.png rename to collects/redex/tests/bmps-macosx/metafunction-multi-arg.png diff --git a/collects/redex/private/bmps-macosx/metafunction-subst.png b/collects/redex/tests/bmps-macosx/metafunction-subst.png similarity index 100% rename from collects/redex/private/bmps-macosx/metafunction-subst.png rename to collects/redex/tests/bmps-macosx/metafunction-subst.png diff --git a/collects/redex/private/bmps-macosx/metafunction.png b/collects/redex/tests/bmps-macosx/metafunction.png similarity index 100% rename from collects/redex/private/bmps-macosx/metafunction.png rename to collects/redex/tests/bmps-macosx/metafunction.png diff --git a/collects/redex/private/bmps-macosx/metafunctions-multiple.png b/collects/redex/tests/bmps-macosx/metafunctions-multiple.png similarity index 100% rename from collects/redex/private/bmps-macosx/metafunctions-multiple.png rename to collects/redex/tests/bmps-macosx/metafunctions-multiple.png diff --git a/collects/redex/private/bmps-macosx/red2.png b/collects/redex/tests/bmps-macosx/red2.png similarity index 100% rename from collects/redex/private/bmps-macosx/red2.png rename to collects/redex/tests/bmps-macosx/red2.png diff --git a/collects/redex/private/bmps-macosx/reduction-relation.png b/collects/redex/tests/bmps-macosx/reduction-relation.png similarity index 100% rename from collects/redex/private/bmps-macosx/reduction-relation.png rename to collects/redex/tests/bmps-macosx/reduction-relation.png diff --git a/collects/redex/tests/bmps-macosx/superscripts.png b/collects/redex/tests/bmps-macosx/superscripts.png new file mode 100644 index 0000000000..69484218f2 Binary files /dev/null and b/collects/redex/tests/bmps-macosx/superscripts.png differ diff --git a/collects/redex/private/bmps-macosx/unix-extended-language.png b/collects/redex/tests/bmps-macosx/unix-extended-language.png similarity index 100% rename from collects/redex/private/bmps-macosx/unix-extended-language.png rename to collects/redex/tests/bmps-macosx/unix-extended-language.png diff --git a/collects/redex/private/bmps-macosx/unix-extended-reduction-relation.png b/collects/redex/tests/bmps-macosx/unix-extended-reduction-relation.png similarity index 100% rename from collects/redex/private/bmps-macosx/unix-extended-reduction-relation.png rename to collects/redex/tests/bmps-macosx/unix-extended-reduction-relation.png diff --git a/collects/redex/private/bmps-macosx/unix-language-nox.png b/collects/redex/tests/bmps-macosx/unix-language-nox.png similarity index 100% rename from collects/redex/private/bmps-macosx/unix-language-nox.png rename to collects/redex/tests/bmps-macosx/unix-language-nox.png diff --git a/collects/redex/private/bmps-macosx/unix-language.png b/collects/redex/tests/bmps-macosx/unix-language.png similarity index 100% rename from collects/redex/private/bmps-macosx/unix-language.png rename to collects/redex/tests/bmps-macosx/unix-language.png diff --git a/collects/redex/private/bmps-macosx/unix-lw.png b/collects/redex/tests/bmps-macosx/unix-lw.png similarity index 100% rename from collects/redex/private/bmps-macosx/unix-lw.png rename to collects/redex/tests/bmps-macosx/unix-lw.png diff --git a/collects/redex/private/bmps-macosx/unix-metafunction-Name-vertical.png b/collects/redex/tests/bmps-macosx/unix-metafunction-Name-vertical.png similarity index 100% rename from collects/redex/private/bmps-macosx/unix-metafunction-Name-vertical.png rename to collects/redex/tests/bmps-macosx/unix-metafunction-Name-vertical.png diff --git a/collects/redex/private/bmps-macosx/unix-metafunction-Name.png b/collects/redex/tests/bmps-macosx/unix-metafunction-Name.png similarity index 100% rename from collects/redex/private/bmps-macosx/unix-metafunction-Name.png rename to collects/redex/tests/bmps-macosx/unix-metafunction-Name.png diff --git a/collects/redex/private/bmps-macosx/unix-metafunction-T.png b/collects/redex/tests/bmps-macosx/unix-metafunction-T.png similarity index 100% rename from collects/redex/private/bmps-macosx/unix-metafunction-T.png rename to collects/redex/tests/bmps-macosx/unix-metafunction-T.png diff --git a/collects/redex/private/bmps-macosx/unix-metafunction-TL.png b/collects/redex/tests/bmps-macosx/unix-metafunction-TL.png similarity index 100% rename from collects/redex/private/bmps-macosx/unix-metafunction-TL.png rename to collects/redex/tests/bmps-macosx/unix-metafunction-TL.png diff --git a/collects/redex/private/bmps-macosx/unix-metafunction-multi-arg.png b/collects/redex/tests/bmps-macosx/unix-metafunction-multi-arg.png similarity index 100% rename from collects/redex/private/bmps-macosx/unix-metafunction-multi-arg.png rename to collects/redex/tests/bmps-macosx/unix-metafunction-multi-arg.png diff --git a/collects/redex/private/bmps-macosx/unix-metafunction-subst.png b/collects/redex/tests/bmps-macosx/unix-metafunction-subst.png similarity index 100% rename from collects/redex/private/bmps-macosx/unix-metafunction-subst.png rename to collects/redex/tests/bmps-macosx/unix-metafunction-subst.png diff --git a/collects/redex/private/bmps-macosx/unix-metafunction.png b/collects/redex/tests/bmps-macosx/unix-metafunction.png similarity index 100% rename from collects/redex/private/bmps-macosx/unix-metafunction.png rename to collects/redex/tests/bmps-macosx/unix-metafunction.png diff --git a/collects/redex/private/bmps-macosx/unix-metafunctions-multiple.png b/collects/redex/tests/bmps-macosx/unix-metafunctions-multiple.png similarity index 100% rename from collects/redex/private/bmps-macosx/unix-metafunctions-multiple.png rename to collects/redex/tests/bmps-macosx/unix-metafunctions-multiple.png diff --git a/collects/redex/private/bmps-macosx/unix-reduction-relation.png b/collects/redex/tests/bmps-macosx/unix-reduction-relation.png similarity index 100% rename from collects/redex/private/bmps-macosx/unix-reduction-relation.png rename to collects/redex/tests/bmps-macosx/unix-reduction-relation.png diff --git a/collects/redex/tests/bmps-unix/extended-language.png b/collects/redex/tests/bmps-unix/extended-language.png new file mode 100644 index 0000000000..26cbf6fb00 Binary files /dev/null and b/collects/redex/tests/bmps-unix/extended-language.png differ diff --git a/collects/redex/tests/bmps-unix/extended-reduction-relation.png b/collects/redex/tests/bmps-unix/extended-reduction-relation.png new file mode 100644 index 0000000000..4980d31457 Binary files /dev/null and b/collects/redex/tests/bmps-unix/extended-reduction-relation.png differ diff --git a/collects/redex/tests/bmps-unix/language-nox.png b/collects/redex/tests/bmps-unix/language-nox.png new file mode 100644 index 0000000000..67452ef86a Binary files /dev/null and b/collects/redex/tests/bmps-unix/language-nox.png differ diff --git a/collects/redex/tests/bmps-unix/language.png b/collects/redex/tests/bmps-unix/language.png new file mode 100644 index 0000000000..add73ae87a Binary files /dev/null and b/collects/redex/tests/bmps-unix/language.png differ diff --git a/collects/redex/tests/bmps-unix/lw.png b/collects/redex/tests/bmps-unix/lw.png new file mode 100644 index 0000000000..39ff404613 Binary files /dev/null and b/collects/redex/tests/bmps-unix/lw.png differ diff --git a/collects/redex/tests/bmps-unix/metafunction-Name-vertical.png b/collects/redex/tests/bmps-unix/metafunction-Name-vertical.png new file mode 100644 index 0000000000..3698cfbc26 Binary files /dev/null and b/collects/redex/tests/bmps-unix/metafunction-Name-vertical.png differ diff --git a/collects/redex/tests/bmps-unix/metafunction-Name.png b/collects/redex/tests/bmps-unix/metafunction-Name.png new file mode 100644 index 0000000000..0271369025 Binary files /dev/null and b/collects/redex/tests/bmps-unix/metafunction-Name.png differ diff --git a/collects/redex/tests/bmps-unix/metafunction-T.png b/collects/redex/tests/bmps-unix/metafunction-T.png new file mode 100644 index 0000000000..9cf60cd64f Binary files /dev/null and b/collects/redex/tests/bmps-unix/metafunction-T.png differ diff --git a/collects/redex/tests/bmps-unix/metafunction-TL.png b/collects/redex/tests/bmps-unix/metafunction-TL.png new file mode 100644 index 0000000000..a2f6291b00 Binary files /dev/null and b/collects/redex/tests/bmps-unix/metafunction-TL.png differ diff --git a/collects/redex/tests/bmps-unix/metafunction-multi-arg.png b/collects/redex/tests/bmps-unix/metafunction-multi-arg.png new file mode 100644 index 0000000000..f83b42b9c7 Binary files /dev/null and b/collects/redex/tests/bmps-unix/metafunction-multi-arg.png differ diff --git a/collects/redex/tests/bmps-unix/metafunction-subst.png b/collects/redex/tests/bmps-unix/metafunction-subst.png new file mode 100644 index 0000000000..8eb9e665c7 Binary files /dev/null and b/collects/redex/tests/bmps-unix/metafunction-subst.png differ diff --git a/collects/redex/tests/bmps-unix/metafunction.png b/collects/redex/tests/bmps-unix/metafunction.png new file mode 100644 index 0000000000..4c607c9c5a Binary files /dev/null and b/collects/redex/tests/bmps-unix/metafunction.png differ diff --git a/collects/redex/tests/bmps-unix/metafunctions-multiple.png b/collects/redex/tests/bmps-unix/metafunctions-multiple.png new file mode 100644 index 0000000000..f162300418 Binary files /dev/null and b/collects/redex/tests/bmps-unix/metafunctions-multiple.png differ diff --git a/collects/redex/tests/bmps-unix/red2.png b/collects/redex/tests/bmps-unix/red2.png new file mode 100644 index 0000000000..585640772b Binary files /dev/null and b/collects/redex/tests/bmps-unix/red2.png differ diff --git a/collects/redex/tests/bmps-unix/reduction-relation.png b/collects/redex/tests/bmps-unix/reduction-relation.png new file mode 100644 index 0000000000..09f92469fb Binary files /dev/null and b/collects/redex/tests/bmps-unix/reduction-relation.png differ diff --git a/collects/redex/tests/bmps-unix/superscripts.png b/collects/redex/tests/bmps-unix/superscripts.png new file mode 100644 index 0000000000..51887d799f Binary files /dev/null and b/collects/redex/tests/bmps-unix/superscripts.png differ diff --git a/collects/redex/private/color-test.ss b/collects/redex/tests/color-test.ss similarity index 100% rename from collects/redex/private/color-test.ss rename to collects/redex/tests/color-test.ss diff --git a/collects/redex/private/config.ss b/collects/redex/tests/config.ss similarity index 100% rename from collects/redex/private/config.ss rename to collects/redex/tests/config.ss diff --git a/collects/redex/private/core-layout-test.ss b/collects/redex/tests/core-layout-test.ss similarity index 97% rename from collects/redex/private/core-layout-test.ss rename to collects/redex/tests/core-layout-test.ss index b1edc2bc72..a184bc77c1 100644 --- a/collects/redex/private/core-layout-test.ss +++ b/collects/redex/tests/core-layout-test.ss @@ -1,7 +1,7 @@ #lang scheme/base -(require "core-layout.ss" - "loc-wrapper.ss" +(require "../private/core-layout.ss" + "../private/loc-wrapper.ss" "lw-test-util.ss" "test-util.ss" (lib "struct.ss")) diff --git a/collects/redex/private/hole-test.ss b/collects/redex/tests/hole-test.ss similarity index 100% rename from collects/redex/private/hole-test.ss rename to collects/redex/tests/hole-test.ss diff --git a/collects/redex/private/keyword-macros-test.ss b/collects/redex/tests/keyword-macros-test.ss similarity index 97% rename from collects/redex/private/keyword-macros-test.ss rename to collects/redex/tests/keyword-macros-test.ss index ab3ddc8dbb..97491d3e9f 100644 --- a/collects/redex/private/keyword-macros-test.ss +++ b/collects/redex/tests/keyword-macros-test.ss @@ -1,6 +1,6 @@ #lang scheme -(require "keyword-macros.ss" +(require "../private/keyword-macros.ss" "test-util.ss") (reset-count) diff --git a/collects/redex/private/lw-test-util.ss b/collects/redex/tests/lw-test-util.ss similarity index 96% rename from collects/redex/private/lw-test-util.ss rename to collects/redex/tests/lw-test-util.ss index fb6e335dc4..a1dd92c934 100644 --- a/collects/redex/private/lw-test-util.ss +++ b/collects/redex/tests/lw-test-util.ss @@ -1,5 +1,5 @@ (module lw-test-util mzscheme - (require "loc-wrapper.ss") + (require "../private/loc-wrapper.ss") (provide normalize-lw) (define (normalize-lw lw) diff --git a/collects/redex/private/lw-test.ss b/collects/redex/tests/lw-test.ss similarity index 99% rename from collects/redex/private/lw-test.ss rename to collects/redex/tests/lw-test.ss index 109b17c9a5..89dd8babc2 100644 --- a/collects/redex/private/lw-test.ss +++ b/collects/redex/tests/lw-test.ss @@ -51,7 +51,7 @@ (module lw-test mzscheme (require "test-util.ss" - "loc-wrapper.ss" + "../private/loc-wrapper.ss" "lw-test-util.ss") (reset-count) diff --git a/collects/redex/private/matcher-test.ss b/collects/redex/tests/matcher-test.ss similarity index 99% rename from collects/redex/private/matcher-test.ss rename to collects/redex/tests/matcher-test.ss index 6866eae34a..640f6b20d8 100644 --- a/collects/redex/private/matcher-test.ss +++ b/collects/redex/tests/matcher-test.ss @@ -1,5 +1,5 @@ (module matcher-test mzscheme - (require "matcher.ss" + (require "../private/matcher.ss" (only "test-util.ss" equal/bindings?) (lib "list.ss")) diff --git a/collects/redex/private/pict-test.ss b/collects/redex/tests/pict-test.ss similarity index 100% rename from collects/redex/private/pict-test.ss rename to collects/redex/tests/pict-test.ss diff --git a/collects/redex/private/rg-test.ss b/collects/redex/tests/rg-test.ss similarity index 83% rename from collects/redex/private/rg-test.ss rename to collects/redex/tests/rg-test.ss index 307b595aa0..b233998dae 100644 --- a/collects/redex/private/rg-test.ss +++ b/collects/redex/tests/rg-test.ss @@ -1,12 +1,15 @@ #lang scheme (require "test-util.ss" - "reduction-semantics.ss" - "matcher.ss" - "term.ss" - "rg.ss" - "keyword-macros.ss" - "error.ss") + "../private/reduction-semantics.ss" + "../private/matcher.ss" + "../private/term.ss" + "../private/rg.ss" + "../private/keyword-macros.ss" + "../private/error.ss") + +(define-namespace-anchor nsa) +(define ns (namespace-anchor->namespace nsa)) (reset-count) @@ -111,23 +114,6 @@ (test (pick-string lits 0 (make-random .5 1 0 1 1 1 2 1)) "abc") (test (pick-var lits 0 (make-random .01 1 0 1 1 1 2 1)) 'abc)) -(let () - (define-language L - (a 5 (x a)) - (b 4)) - (test (pick-nt 'a #f L 1 'dontcare) - (nt-rhs (car (compiled-lang-lang L)))) - (test (pick-nt 'a #f L preferred-production-threshold 'dontcare (make-random 1)) - (nt-rhs (car (compiled-lang-lang L)))) - (let ([pref (car (nt-rhs (car (compiled-lang-lang L))))]) - (test (pick-nt 'a #f L preferred-production-threshold - (make-pref-prods 'dont-care - (make-immutable-hash `((a ,pref)))) - (make-random 0)) - (list pref))) - (test (pick-nt 'b #f L preferred-production-threshold #f) - (nt-rhs (cadr (compiled-lang-lang L))))) - (define-syntax raised-exn-msg (syntax-rules () [(_ expr) (raised-exn-msg exn:fail? expr)] @@ -141,7 +127,7 @@ (define (patterns . selectors) (map (λ (selector) - (λ (name cross? lang size pref-prods) + (λ (name cross? lang sizes) (list (selector (nt-rhs (nt-by-name lang name cross?)))))) selectors)) @@ -158,15 +144,14 @@ (test (raised-exn-msg (iter)) #rx"empty")) (define (decisions #:var [var pick-var] - #:nt [nt pick-nt] + #:nt [nt pick-nts] #:str [str pick-string] #:num [num pick-number] #:nat [nat pick-natural] #:int [int pick-integer] #:real [real pick-real] #:any [any pick-any] - #:seq [seq pick-sequence-length] - #:pref [pref pick-preferred-productions]) + #:seq [seq pick-sequence-length]) (define-syntax decision (syntax-rules () [(_ d) (if (procedure? d) (λ () d) (iterator (quote d) d))])) @@ -179,14 +164,13 @@ (define next-real-decision (decision real)) (define next-string-decision (decision str)) (define next-any-decision (decision any)) - (define next-sequence-decision (decision seq)) - (define next-pref-prods-decision (decision pref)))) + (define next-sequence-decision (decision seq)))) (define-syntax generate-term/decisions (syntax-rules () [(_ lang pat size attempt decisions) (parameterize ([generation-decisions decisions]) - (generate-term lang pat size #:attempt attempt))])) + (generate-term lang pat size #:attempt-num attempt))])) (let () (define-language lc @@ -216,6 +200,17 @@ #:var (list (λ _ 'x) (λ _ 'y)))) '(x y))) +(let () + (define-language L + (n 1)) + (test ((generate-term L n) 0) 1) + (test ((generate-term L n) 0 #:retries 0) 1) + (test ((generate-term L n) 0 #:attempt-num 0) 1) + (test (with-handlers ([exn:fail:syntax? exn-message]) + (parameterize ([current-namespace ns]) + (expand #'(generate-term M n)))) + #rx"generate-term: expected a identifier defined by define-language( in: M)?$")) + ;; variable-except pattern (let () (define-language var @@ -231,17 +226,17 @@ (n natural) (i integer) (r real)) - (test (let ([n (generate-term L n 0 #:attempt 10000)]) + (test (let ([n (generate-term L n 0 #:attempt-num 10000)]) (and (integer? n) (exact? n) (not (negative? n)))) #t) (test (generate-term/decisions L n 0 1 (decisions #:nat (λ (_) 42))) 42) - (test (let ([i (generate-term L i 0 #:attempt 10000)]) + (test (let ([i (generate-term L i 0 #:attempt-num 10000)]) (and (integer? i) (exact? i))) #t) (test (generate-term/decisions L i 0 1 (decisions #:int (λ (_) -42))) -42) - (test (real? (generate-term L r 0 #:attempt 10000)) #t) + (test (real? (generate-term L r 0 #:attempt-num 10000)) #t) (test (generate-term/decisions L r 0 1 (decisions #:real (λ (_) 4.2))) 4.2)) (let () @@ -539,77 +534,23 @@ (get-output-string p) (close-output-port p)))) -;; preferred productions -(let ([make-pick-nt (λ opt (λ req (apply pick-nt (append req opt))))]) - (define-language L - (e (+ e e) (* e e) 7)) - (define-language M (e 0) (e-e 1)) - - (let ([pats (λ (L) (nt-rhs (car (compiled-lang-lang L))))]) - (test - (generate-term/decisions - L e 2 preferred-production-threshold - (decisions #:pref (list (λ (L) (make-pref-prods - 'dont-care - (make-immutable-hash `((e ,(car (pats L)))))))) - #:nt (make-pick-nt (make-random 0 0 0)))) - '(+ (+ 7 7) (+ 7 7))) - (test - (generate-term/decisions - L any 2 preferred-production-threshold - (decisions #:nt (patterns first) - #:var (list (λ _ 'x)) - #:any (list (λ (lang sexp) (values sexp 'sexp))))) - 'x) - (test - (generate-term/decisions - L any 2 preferred-production-threshold - (decisions #:pref (list (λ (L) (make-pref-prods - 'dont-care - (make-immutable-hash `((e ,(car (pats L)))))))) - #:nt (make-pick-nt (make-random 0 0 0)) - #:any (list (λ (lang sexp) (values lang 'e))))) - '(+ (+ 7 7) (+ 7 7))) - (test - (generate-term/decisions - M (cross e) 2 preferred-production-threshold - (decisions #:nt (make-pick-nt (make-random) (λ (att rand) #t)))) - (term hole)) - (test - (generate-term/decisions - M e-e 2 preferred-production-threshold - (decisions #:nt (make-pick-nt (make-random) (λ (att rand) #t)))) - 1) - - (test - (let ([generated null]) - (output - (λ () - (check-reduction-relation - (reduction-relation L (--> e e)) - (λ (t) (set! generated (cons t generated))) - #:decisions (decisions #:nt (make-pick-nt (make-random) - (λ (att rand) #t)) - #:pref (list (λ (_) 'dontcare) - (λ (_) 'dontcare) - (λ (_) 'dontcare) - ; size 0 terms prior to this attempt - (λ (L) (make-pref-prods - 'dont-care - (make-immutable-hash `((e ,(car (pats L))))))) - (λ (L) (make-pref-prods - 'dont-care - (make-immutable-hash `((e ,(cadr (pats L))))))))) - #:attempts 5))) - generated) - '((* 7 7) (+ 7 7) 7 7 7)))) - ;; redex-check (let () (define-language lang (d 5) (e e 4) (n number)) + + (test (redex-check lang d #t #:attempts 1 #:print? (not #t)) #t) + (test (redex-check lang d #f #:print? #f) + (make-counterexample 5)) + (let ([exn (with-handlers ([exn:fail:redex:test? values]) + (redex-check lang d (error 'boom ":(") #:print? #f) + 'not-an-exn)]) + (test (exn-message exn) "checking 5 raises an exception:\nboom: :(") + (test (exn-message (exn:fail:redex:test-source exn)) "boom: :(") + (test (exn:fail:redex:test-term exn) 5)) + (test (output (λ () (redex-check lang d #f))) #rx"redex-check: .*:.*\ncounterexample found after 1 attempt:\n5\n") (test (output (λ () (redex-check lang d #t))) @@ -644,17 +585,28 @@ (--> 0 dontcare z))))) #rx"counterexample found after 1 attempt with z:\n0\n") - (let ([generated null]) + (let ([generated null] + [R (reduction-relation + lang + (--> 1 dontcare) + (--> 2 dontcare))]) (test (output (λ () (redex-check lang n (set! generated (cons (term n) generated)) #:attempts 5 - #:source (reduction-relation - lang - (--> 1 dontcare) - (--> 2 dontcare))))) + #:source R))) #rx"no counterexamples.*with each clause") - (test generated '(2 2 1 1))) + (test generated '(2 2 1 1)) + + (test (redex-check lang any #t + #:attempts 1 + #:source R + #:print? (not #t)) + #t) + (test (redex-check lang any (= (term any) 1) + #:source R + #:print? #f) + (make-counterexample 2))) (let () (define-metafunction lang @@ -665,7 +617,16 @@ (redex-check lang (n) (eq? 42 (term n)) #:attempts 1 #:source mf))) - #px"counterexample found after 1 attempt with clause at .*:\\d+:\\d+:\n\\(0\\)\n")) + #px"counterexample found after 1 attempt with clause at .*:\\d+:\\d+:\n\\(0\\)\n") + (test (redex-check lang any #t + #:attempts 1 + #:source mf + #:print? (not #t)) + #t) + (test (redex-check lang any (= (car (term any)) 42) + #:source mf + #:print? #f) + (make-counterexample '(0)))) (let () (define-metafunction lang @@ -790,6 +751,14 @@ (E* hole E*) (n 4)) + (let ([R (reduction-relation + L + (--> 1 2) + (--> 2 3))]) + (test (check-reduction-relation R (λ (_) #t) #:print? #f) #t) + (test (counterexample-term (check-reduction-relation R (curry = 1) #:print? #f)) + 2)) + (let ([generated null] [R (reduction-relation L @@ -857,6 +826,11 @@ (define-metafunction empty [(n (side-condition any #f)) any]) + (test (check-metafunction m (λ (_) #t) #:print? #f) #t) + (test (counterexample-term + (check-metafunction m (compose (curry = 1) car) #:print? #f)) + '(2)) + (let ([generated null]) (test (begin (output @@ -890,89 +864,6 @@ (check-metafunction n (λ (_) #t) #:retries 42)) #rx"check-metafunction: unable .* in 42")) -;; custom generators -(let () - (define-language L - (x variable)) - - (test - (generate-term - L x_1 0 - #:custom (λ (pat sz i-h acc env att rec def) - (match pat - ['x (values 'x env)] - [_ (def acc)]))) - 'x) - (test - (let/ec k - (equal? - (generate-term - L (x x) 0 - #:custom (let ([once? #f]) - (λ (pat sz i-h acc env att rec def) - (match pat - ['x (if once? - (k #f) - (begin - (set! once? #t) - (values 'x env)))] - [_ (def acc)])))) - '(x x))) - #t) - - (test - (hash-ref - (let/ec k - (generate-term - L (x (x)) 0 - #:custom (λ (pat sz i-h acc env att rec def) - (match pat - [(struct binder ('x)) - (values 'y (hash-set env pat 'y))] - [(list (struct binder ('x))) (k env)] - [_ (def acc)])))) - (make-binder 'x)) - 'y) - - (test - (generate-term - L (in-hole hole 7) 0 - #:custom (λ (pat sz i-h acc env att rec def) - (match pat - [`(in-hole hole 7) - (rec 'hole #:contractum 7)] - [_ (def acc)]))) - 7) - - (test - (let/ec k - (generate-term - L any 10 - #:attempt 42 - #:custom (λ (pat sz i-h acc env att rec def) (k (list sz att))))) - '(10 42)) - - (test - (let/ec k - (generate-term - L x 10 - #:custom (λ (pat sz i-h acc env att rec def) - (match pat - ['x (rec 7 #:size 0)] - [7 (k sz)] - [_ (def att)])))) - 0) - - (test - (generate-term - L (q 7) 0 - #:custom (λ (pat sz i-h acc env att rec def) - (match pat - ['q (rec '(7 7) #:acc 8)] - [7 (values (or acc 7) env)] - [_ (def att)]))) - '((8 8) 7))) - ;; parse/unparse-pattern (let-syntax ([test-match (syntax-rules () [(_ p x) (test (match x [p #t] [_ #f]) #t)])]) (define-language lang (x variable)) diff --git a/collects/redex/private/run-tests.ss b/collects/redex/tests/run-tests.ss similarity index 97% rename from collects/redex/private/run-tests.ss rename to collects/redex/tests/run-tests.ss index 4ec5971dc6..46fe598acd 100644 --- a/collects/redex/private/run-tests.ss +++ b/collects/redex/tests/run-tests.ss @@ -5,7 +5,7 @@ "config.ss" "test-util.ss") -(set-show-bitmaps? #t) +(set-show-bitmaps? #f) (define test-files '("lw-test.ss" diff --git a/collects/redex/private/term-test.ss b/collects/redex/tests/term-test.ss similarity index 98% rename from collects/redex/private/term-test.ss rename to collects/redex/tests/term-test.ss index 25059c7bbf..ba09d15627 100644 --- a/collects/redex/private/term-test.ss +++ b/collects/redex/tests/term-test.ss @@ -1,6 +1,6 @@ (module term-test scheme - (require "term.ss" - "matcher.ss" + (require "../private/term.ss" + "../private/matcher.ss" "test-util.ss") (reset-count) diff --git a/collects/redex/private/test-util.ss b/collects/redex/tests/test-util.ss similarity index 98% rename from collects/redex/private/test-util.ss rename to collects/redex/tests/test-util.ss index 491f32af3c..8c88e0ecb6 100644 --- a/collects/redex/private/test-util.ss +++ b/collects/redex/tests/test-util.ss @@ -1,6 +1,6 @@ #lang scheme -(require "matcher.ss" +(require "../private/matcher.ss" errortrace/errortrace-lib errortrace/errortrace-key) (provide test test-syn-err tests reset-count @@ -129,4 +129,4 @@ (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 + null))) diff --git a/collects/redex/private/tl-test.ss b/collects/redex/tests/tl-test.ss similarity index 99% rename from collects/redex/private/tl-test.ss rename to collects/redex/tests/tl-test.ss index 8dd90a3884..c45255a96b 100644 --- a/collects/redex/private/tl-test.ss +++ b/collects/redex/tests/tl-test.ss @@ -1,9 +1,9 @@ (module tl-test scheme (require "../reduction-semantics.ss" "test-util.ss" - (only-in "matcher.ss" make-bindings make-bind) + (only-in "../private/matcher.ss" make-bindings make-bind) scheme/match - "struct.ss") + "../private/struct.ss") (reset-count) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index df4650e6ca..a076d01b21 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "23jan2010") +#lang scheme/base (provide stamp) (define stamp "29jan2010") diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss index 8336322b00..d958780c51 100644 --- a/collects/scheme/sandbox.ss +++ b/collects/scheme/sandbox.ss @@ -1,6 +1,7 @@ #lang scheme/base (require scheme/port + scheme/path scheme/list scheme/string syntax/moddep @@ -444,7 +445,7 @@ (cond [(and p (null? (cdr inps))) (port-count-lines! p) (parameterize ([current-input-port p]) - (begin0 ((sandbox-reader) source) + (begin0 ((sandbox-reader) (or (object-name p) source)) ;; close a port if we opened it (unless (eq? p (car inps)) (close-input-port p))))] [p (error 'input->code "ambiguous inputs: ~e" inps)] @@ -550,11 +551,17 @@ (module->namespace `(quote ,(syntax-e mod)))))] [_else #f])]) ;; the actual evaluation happens under the specified limits - ((limit-thunk (lambda () - (if (and (pair? program) (eq? 'begin (car program))) - (eval* (cdr program)) - (eval program)) - (when ns (set! ns (ns)))))) + (parameterize ([current-load-relative-directory + (let* ([d (and (syntax? program) (syntax-source program))] + [d (and (path-string? d) (path-only d))]) + (if (and d (directory-exists? d)) + d + (current-load-relative-directory)))]) + ((limit-thunk (lambda () + (if (and (pair? program) (eq? 'begin (car program))) + (eval* (cdr program)) + (eval program)) + (when ns (set! ns (ns))))))) (when uncovered! (let ([get (let ([ns (current-namespace)]) (lambda () (eval '(get-uncovered-expressions) ns)))]) diff --git a/collects/scribble/tools/drscheme-buttons.ss b/collects/scribble/tools/drscheme-buttons.ss index 31bc41be41..a40503e06c 100644 --- a/collects/scribble/tools/drscheme-buttons.ss +++ b/collects/scribble/tools/drscheme-buttons.ss @@ -40,7 +40,6 @@ (dynamic-require 'scribble/run #f) (cond [(equal? label "HTML") - (system (format "firefox ~a" (path-replace-suffix name suffix))) (send-url/file (path-replace-suffix fn suffix))] [else (system (format "open ~a" (path-replace-suffix name suffix)))])) (message-box "Scribble" (get-output-string p) drs-frame)) diff --git a/collects/scribblings/gui/blurbs.ss b/collects/scribblings/gui/blurbs.ss index 72800aaa37..a9210b9460 100644 --- a/collects/scribblings/gui/blurbs.ss +++ b/collects/scribblings/gui/blurbs.ss @@ -203,7 +203,7 @@ information@|details|, even if the editor currently has delayed refreshing (see monitor @|whatsit| changes.}) (define (MonitorCallbackX a b c d) - (MonitorMethod a b @elem{the @|d|callback procedure (provided as an initialization argument)} c)) + (MonitorMethod a b @elem{the @|d| callback procedure (provided as an initialization argument)} c)) (define (MonitorCallback a b c) (MonitorCallbackX a b c "control")) diff --git a/collects/scribblings/gui/editor-overview.scrbl b/collects/scribblings/gui/editor-overview.scrbl index b19728ba53..b6b6e253ad 100644 --- a/collects/scribblings/gui/editor-overview.scrbl +++ b/collects/scribblings/gui/editor-overview.scrbl @@ -530,7 +530,7 @@ When an editor is loaded and a header/footer record is encountered, be loaded. See also @method[editor<%> write-headers-to-file] and - @method[editor<%> write-headers-to-file]. + @method[editor<%> read-header-from-file]. @section[#:tag "editoreol"]{End of Line Ambiguity} diff --git a/collects/scribblings/gui/radio-box-class.scrbl b/collects/scribblings/gui/radio-box-class.scrbl index a9bc3275b7..17958e7aa7 100644 --- a/collects/scribblings/gui/radio-box-class.scrbl +++ b/collects/scribblings/gui/radio-box-class.scrbl @@ -28,7 +28,7 @@ Whenever the user changes the selected radio button, the radio box's 'vertical-label 'horizontal-label 'deleted)) '(vertical)] - [selection exact-nonnegative-integer? 0] + [selection (or/c exact-nonnegative-integer? #f) 0] [font (is-a?/c font%) normal-control-font] [enabled any/c #t] [vert-margin (integer-in 0 1000) 2] @@ -64,8 +64,9 @@ The @scheme[style] argument must include either @scheme['vertical] for a @HVLabelNote[@scheme[style]]{radio box} @DeletedStyleNote[@scheme[style] @scheme[parent]]{radio box} By default, the first radio button is initially selected. If - @scheme[selection] is positive, it is passed to @method[radio-box% - set-selection] to set the initial radio button selection. + @scheme[selection] is positive or @scheme[#f], it is passed to + @method[radio-box% set-selection] to set the initial radio button + selection. @FontKWs[@scheme[font]] @WindowKWs[@scheme[enabled]] @SubareaKWs[] @AreaKWs[] @@ -115,10 +116,10 @@ Returns the number of radio buttons in the radio box. } @defmethod[(get-selection) - exact-nonnegative-integer?]{ + (or/c exact-nonnegative-integer? #f)]{ -Gets the position of the selected radio button. Radio buttons are -numbered from @scheme[0]. +Gets the position of the selected radio button, returning @scheme[#f] +if no button is selected. Radio buttons are numbered from @scheme[0]. } @@ -139,10 +140,11 @@ box, @|MismatchExn|. } -@defmethod[(set-selection [n exact-nonnegative-integer?]) +@defmethod[(set-selection [n (or/c exact-nonnegative-integer? #f)]) void?]{ -Sets the selected radio button by position. (The control's callback +Sets the selected radio button by position, or deselects all radio + buttons if @scheme[n] is @scheme[#f]. (The control's callback procedure is @italic{not} invoked.) Radio buttons are numbered from @scheme[0]. If @scheme[n] is equal to or larger than the number of radio buttons in the radio box, @|MismatchExn|. diff --git a/collects/scribblings/places/info.ss b/collects/scribblings/places/info.ss new file mode 100644 index 0000000000..22fe7bf873 --- /dev/null +++ b/collects/scribblings/places/info.ss @@ -0,0 +1,3 @@ +#lang setup/infotab + +(define scribblings '(("places.scrbl" ()))) diff --git a/collects/scribblings/places/places.scrbl b/collects/scribblings/places/places.scrbl new file mode 100644 index 0000000000..7c518458e1 --- /dev/null +++ b/collects/scribblings/places/places.scrbl @@ -0,0 +1,90 @@ +#lang scribble/doc + +@title{@bold{Places}: Coarse-grained Parallelism} + +@; ---------------------------------------------------------------------- + +@(require scribble/manual + scribble/urls + scribble/struct + (for-label scheme + scheme/base + scheme/contract + scheme/place)) + +@; ---------------------------------------------------------------------- + +The PLT futures API enables the development of parallel programs which +take advantage of machines with multiple processors, cores, or +hardware threads. + +@defmodule[scheme/place]{} + +@defproc[(place [module-path module-path?] [start-proc proc?] [place-channel place-ch?]) place?]{ + Starts running @scheme[start-proc] in parallel. scheme[start-proc] must + be a function defined in @scheme[module-path]. The @scheme[place] + procedure returns immediately with a place descriptor value. +} + +@defproc[(place-wait [p place?]) exact-integer?]{ + Returns the return value of a completed place @scheme[p], blocking until + the place completes (if it has not already completed). +} + +@defproc[(place? [x any/c]) boolean?]{ + Returns @scheme[#t] if @scheme[x] is a place. +} + +@defproc[(place-ch-send [ch place-ch?] [x any/c]) void]{ + Sends an immutable message @scheme[x] on channel @scheme[ch]. +} + +@defproc[(place-ch-recv [p place-ch?]) any/c]{ + Returns an immutable message received on channel @scheme[ch]. +} + +@defproc[(place-ch? [x any/c]) boolean?]{ + Returns @scheme[#t] if @scheme[x] is a place-ch. +} + +@section[#:tag "example"]{How Do I Keep Those Cores Busy?} + +This code launches two places passing 1 and 2 as the initial channels +and then waits for the places to complete and return. + +@schemeblock[ + (let ((pls (map (lambda (x) (place "place_worker.ss" 'place-main x)) + (list 1 2)))) + (map place-wait pls)) +] + +This is the code for the place_worker.ss module that each place will execute. + +@schemeblock[ +(module place_worker scheme + (provide place-main) + + (define (place-main x) + (printf "IN PLACE ~a~n" x))) +] + + +@section[#:tag "messagepassingparallelism"]{Message Passing Parallelism} + +Places can only communicate by passing immutable messages on place-channels. + +@section[#:tag "logging"]{Architecture and Garbage Collection} + +Immutable messages communicated on place-channels are first copied to a shared +garbage collector called the master. The master waits on a barrier until all places garbage +collectors have collected. Once the master is released it collects and resets +the barrier. + +@section[#:tag "compiling"]{Enabling Places in MzScheme Builds} + +PLT's parallel-places support is only enabled if you pass +@DFlag{enable-places} 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[place] usage is a syntax error. +@; @FIXME{use threads to emulate places maybe?} diff --git a/collects/scribblings/reference/custom-ports.scrbl b/collects/scribblings/reference/custom-ports.scrbl index fe8bda671f..866e1ef36a 100644 --- a/collects/scribblings/reference/custom-ports.scrbl +++ b/collects/scribblings/reference/custom-ports.scrbl @@ -72,11 +72,11 @@ The arguments implement the port as follows: @scheme[peek] is called again; or} @item{a @tech{synchronizable event} (see @secref["sync"]) other - than a pipe input port that becomes ready when the read is - complete (roughly): the event's value can one of the above three - results or another event like itself; in the last case, a - reading process loops with @scheme[sync] until it gets a - non-event result.} + than a pipe input port or procedure of arity four; the event + becomes ready when the read is complete (roughly): the event's + value can one of the above three results or another event like + itself; in the last case, a reading process loops with + @scheme[sync] until it gets a non-event result.} ] diff --git a/collects/scribblings/reference/evts.scrbl b/collects/scribblings/reference/evts.scrbl index 05fd41bffc..b423652918 100644 --- a/collects/scribblings/reference/evts.scrbl +++ b/collects/scribblings/reference/evts.scrbl @@ -324,13 +324,13 @@ A @tech{structure type property} that identifies structure types whose @itemize[ - @item{An event @scheme[evt]: In this case, using the structure as an - event is equivalent to using @scheme[evt].} + @item{An event @scheme[_evt]: In this case, using the structure as an + event is equivalent to using @scheme[_evt].} - @item{A procedure @scheme[proc] of one argument: In this case, the + @item{A procedure @scheme[_proc] of one argument: In this case, the structure is similar to an event generated by @scheme[guard-evt], except that the would-be guard - procedure @scheme[proc] receives the structure as an argument, instead + procedure @scheme[_proc] receives the structure as an argument, instead of no arguments.} @item{An exact, non-negative integer between @scheme[0] (inclusive) diff --git a/collects/scribblings/reference/sandbox.scrbl b/collects/scribblings/reference/sandbox.scrbl index e36db71e3b..7148aea2e2 100644 --- a/collects/scribblings/reference/sandbox.scrbl +++ b/collects/scribblings/reference/sandbox.scrbl @@ -811,7 +811,7 @@ in a way that depends on the setting of @scheme[(sandbox-output)] or Retrieves uncovered expression from an evaluator, as longs as the @scheme[sandbox-coverage-enabled] parameter had a true value when the -evaluator was created. Otherwise, and exception is raised to indicate +evaluator was created. Otherwise, an exception is raised to indicate that no coverage information is available. The @scheme[prog?] argument specifies whether to obtain expressions that diff --git a/collects/setup/scribble.ss b/collects/setup/scribble.ss index 1cb1e5ebe2..6f2baa92b3 100644 --- a/collects/setup/scribble.ss +++ b/collects/setup/scribble.ss @@ -427,10 +427,11 @@ (memq 'depends-all-main (doc-flags doc))) (and auto-user? (memq 'depends-all (doc-flags doc)))))]) - (setup-printf - (cond [up-to-date? "using"] [can-run? "running"] [else "skipping"]) - "~a" - (path->name (doc-src-file doc))) + (when (or (not up-to-date?) (verbose)) + (setup-printf + (cond [up-to-date? "using"] [can-run? "running"] [else "skipping"]) + "~a" + (path->name (doc-src-file doc)))) (if up-to-date? ;; Load previously calculated info: (render-time diff --git a/collects/stepper/private/annotate.ss b/collects/stepper/private/annotate.ss index 0ba963bdc5..77b7b03e95 100644 --- a/collects/stepper/private/annotate.ss +++ b/collects/stepper/private/annotate.ss @@ -18,6 +18,7 @@ [(_ body bindings) (syntax/loc stx (letrec bindings body))])) + ; CONTRACTS @@ -215,7 +216,7 @@ (stepper-syntax-property #`(#%plain-app #,put-into-xml-table #,rewritten) 'stepper-skipto (list syntax-e cdr car)) - (syntax-recertify rewritten stx (current-code-inspector) #f)))))) + (stepper-recertify rewritten stx)))))) ; @@ -769,7 +770,7 @@ (let*-2vals ([(new-exp bindings) vals]) (2vals (stepper-recertify new-exp exp) (map (lambda (b) - (syntax-recertify b exp (current-code-inspector) #f)) + (stepper-recertify b exp)) bindings))))] ;; this is a terrible hack... until some other language form needs it. It wraps the @@ -1094,10 +1095,6 @@ [else (error 'annotate "unexpected syntax for expression: ~v" (syntax->datum exp))]))))]))) - (define (stepper-recertify new-stx old-stx) - (syntax-recertify new-stx old-stx (current-code-inspector) #f)) - - ;; annotate/top-level : syntax-> syntax ;; expansion of teaching level language programs produces two kinds of ;; expressions: modules containing all of the code in the def'ns window, and @@ -1115,19 +1112,16 @@ ; the 'require' form is used for the test harness [(require module-name) exp] ; the 'dynamic-require' form is used by the actual expander - [(let-values ([(done-already?) . rest1]) (#%plain-app dynamic-wind - void - (#%plain-lambda () . rest2) - (#%plain-lambda () . rest3))) + void + (#%plain-lambda () . rest2) + (#%plain-lambda () . rest3))) exp] [else - ;; I think we can re-enable this error now. I don't want to do it right before a release, though. 2009-05-20 - #; (error `annotate/top-level "unexpected top-level expression: ~a\n" (syntax->datum exp)) - (annotate/module-top-level exp)]))) + #;(annotate/module-top-level exp)]))) #;(define/contract annotate/top-level/acl2 (syntax? . -> . syntax?) @@ -1177,11 +1171,13 @@ [defined-name (if (and (pair? name-list) (null? (cdr name-list))) (car name-list) #f)]) - #`(begin - (define-values (new-var ...) - #,(top-level-annotate/inner (top-level-rewrite #`e) exp defined-name)) - ;; this next expression should deliver the newly computed values to an exp-finished-break - (#%plain-app #,exp-finished-break (#%plain-app list (#%plain-app list #,(lambda () exp) #f (#%plain-lambda () (#%plain-app list new-var ...)))))))] + (stepper-recertify + #`(begin + (define-values (new-var ...) + #,(top-level-annotate/inner (top-level-rewrite #`e) exp defined-name)) + ;; this next expression should deliver the newly computed values to an exp-finished-break + (#%plain-app #,exp-finished-break (#%plain-app list (#%plain-app list #,(lambda () exp) #f (#%plain-lambda () (#%plain-app list new-var ...)))))) + #'e))] [(define-syntaxes (new-vars ...) e) exp] [(#%require specs ...) @@ -1191,17 +1187,25 @@ [(begin . bodies) #`(begin #,@(map annotate/module-top-level (syntax->list #`bodies)))] [(#%plain-app call-with-values (#%plain-lambda () body) print-values) - (stepper-recertify - #`(#%plain-app - call-with-values - (#%plain-lambda () #,(top-level-annotate/inner (top-level-rewrite #`body) exp #f)) - (#%plain-lambda vals - (begin - (#,exp-finished-break (#%plain-app list (#%plain-app list #,(lambda () exp) #f (#%plain-lambda () vals)))) - (#%plain-app - call-with-values (#%plain-lambda () vals) - print-values)))) - exp)] + ;; re-extract the plain-lambda term, to use in recertification: + (let ([lam-for-cert (syntax-case exp (#%plain-app call-with-values) + [(#%plain-app call-with-values lam print-values) #'lam] + [other (error 'annotate/module-top-level "unreachable 2010-01-23 22:14")])]) + ;; this recertify looks to be superfluous now that it has the "transparent" certificate-mode tag, + ;; but it can't hurt, and I'd rather just leave it in here. + (stepper-recertify + #`(#%plain-app + call-with-values + #,(stepper-recertify + #`(#%plain-lambda () #,(top-level-annotate/inner (top-level-rewrite #`body) exp #f)) + lam-for-cert) + (#%plain-lambda vals + (begin + (#,exp-finished-break (#%plain-app list (#%plain-app list #,(lambda () exp) #f (#%plain-lambda () vals)))) + (#%plain-app + call-with-values (#%plain-lambda () vals) + print-values)))) + exp))] [any (stepper-syntax-property exp 'stepper-test-suite-hint) (top-level-annotate/inner (top-level-rewrite exp) exp #f)] @@ -1211,14 +1215,12 @@ ;; which produce arbitrary expressions at the top level. #;(error `annotate/module-top-level "unexpected module-top-level expression to annotate: ~a\n" (syntax->datum exp))])])) + ; body of local - (let* ([annotated-exp (cond - ;; support for ACL2 is commented out. - #;[(and (not (eq? language-level 'testing)) - (string=? (language-level->name language-level) "ACL2 Beginner (beta 8)")) - (annotate/top-level/acl2 main-exp)] - [else - (annotate/top-level main-exp)])]) - annotated-exp)) + (annotate/top-level main-exp)) +(define saved-code-inspector (current-code-inspector)) + +(define (stepper-recertify new-stx old-stx) + (syntax-recertify new-stx old-stx saved-code-inspector #f)) \ No newline at end of file diff --git a/collects/stepper/private/shared.ss b/collects/stepper/private/shared.ss index d5617d1d55..7cb9e0ab37 100644 --- a/collects/stepper/private/shared.ss +++ b/collects/stepper/private/shared.ss @@ -386,10 +386,12 @@ (define (queue-length queue) (length (unbox queue))) + (define saved-code-inspector (current-code-inspector)) + (define (rebuild-stx new old) (syntax-recertify (datum->syntax old new old old) old - (current-code-inspector) + saved-code-inspector #f)) (define break-kind? diff --git a/collects/syntax/parse/experimental.ss b/collects/syntax/parse/experimental.ss new file mode 100644 index 0000000000..90ca5cdf76 --- /dev/null +++ b/collects/syntax/parse/experimental.ss @@ -0,0 +1,94 @@ +#lang scheme/base +(require (for-syntax scheme/base + syntax/parse + syntax/private/stxparse/rep-data)) +(provide define-primitive-splicing-syntax-class) + +(define-syntax (define-primitive-splicing-syntax-class stx) + + (define-syntax-class attr + (pattern name:id + #:with depth #'0) + (pattern [name:id depth:nat])) + + (syntax-parse stx + [(dssp (name:id param:id ...) + (~or (~once (~seq #:attrs (a:attr ...)) + #:name "attributes declaration") + (~once (~seq #:description description) + #:name "description declaration")) ... + proc:expr) + #'(begin + (define (get-description param ...) + description) + (define parser + (lambda (stx param ...) + (let/ec escape + ((mk-check-result 'name '(a.name ...) stx) + (proc stx + (lambda ([msg #f]) + (escape + (if msg + `#s(expect:message ,msg) + `#s(expect:thing + ,(get-description param ...) #f #f))))))))) + (define-syntax name + (make-stxclass 'name '(param ...) + '(#s(attr a.name a.depth #f) ...) + (quote-syntax parser) + (quote-syntax get-description) + #t)))])) + + +(define (mk-check-result name attr-names stx) + (lambda (result) + (unless (list? result) + (error name "parser returned non-list")) + (let ([rlength (length result)]) + (unless (= rlength (+ 2 (length attr-names))) + (error name "parser returned list of wrong length; expected length ~s, got ~e" + (+ 2 (length attr-names)) + result)) + (unless (exact-nonnegative-integer? (cadr result)) + (error name "expected exact nonnegative integer for second element of result list, got ~e" + (cadr result))) + (list* (car result) + (nat->dfc (cadr result) stx) + (cddr result))))) + +(define (nat->dfc nat stx) + (if (zero? nat) + `#s(dfc:empty ,stx) + `#s(dfc:cdr #s(dfc:empty ,stx) ,nat))) + + +#| + +(define-primitive-splicing-syntax-class (name param ...) + #:attrs (attr-decl ...) + #:description description-expr + proc) + +'proc' must take two arguments, 'stx' and 'fail', where 'fail' is an +escaping procedure that indicates failure. 'fail' takes an optional +argument, an error message to attach to the failure. If no message is +given, the syntax class description is used. + +'proc' must return a list of 2+|attrs| elements. The first element is +the rest of the input syntax. The second element is the number of +elements consumed from the input. The rest are the attribute values, +in the same order as given in the #:attrs directive. + +Example: + +(define-primitive-splicing-syntax-class (a-expr) + #:attrs (x) + #:description "a-expr" + (lambda (stx fail) + (syntax-case stx () + [(a b c . rest) + (list #'rest 3 #'(printf "got an A\n"))] + [_ + (fail)]))) + +|# diff --git a/collects/tests/mred/item.ss b/collects/tests/mred/item.ss index 4dd6fd1bfb..f9ff3383b2 100644 --- a/collects/tests/mred/item.ss +++ b/collects/tests/mred/item.ss @@ -1299,6 +1299,7 @@ (define mismatch-err (mk-err exn:fail:contract?)) (define do-sel (lambda (sel n) (for-each (lambda (rb) (sel rb (n rb))) rbs))) + (define sel-false (lambda (sel) (do-sel sel (lambda (rb) #f)))) (define sel-minus (lambda (sel) (do-sel (type-err sel) (lambda (rb) -1)))) (define sel-first (lambda (sel) (do-sel sel (lambda (rb) 0)))) (define sel-middle (lambda (sel) (do-sel sel (lambda (rb) (floor (/ (send rb get-number) 2)))))) @@ -1311,7 +1312,9 @@ (make-object button% (format "Select First~a" title) hp2 (lambda (b e) (sel-first sel))) (make-object button% (format "Select Middle ~a" title) hp2 (lambda (b e) (sel-middle sel))) (make-object button% (format "Select Last~a" title) hp2 (lambda (b e) (sel-last sel))) - (make-object button% (format "Select N~a" title) hp2 (lambda (b e) (sel-N sel)))) + (make-object button% (format "Select N~a" title) hp2 (lambda (b e) (sel-N sel))) + (when (equal? title "") + (make-object button% (format "Select #f~a" title) hp2 (lambda (b e) (sel-false sel))))) (make-selectors "" normal-sel) (make-selectors " by Simulate" simulate-sel) (make-object button% "Check" p diff --git a/collects/tests/mzscheme/benchmarks/common/README.txt b/collects/tests/mzscheme/benchmarks/common/README.txt index cc79243730..ab3f7585a4 100644 --- a/collects/tests/mzscheme/benchmarks/common/README.txt +++ b/collects/tests/mzscheme/benchmarks/common/README.txt @@ -1,7 +1,7 @@ To run a benchmark, assuming you have `mzscheme' in your path: ./auto.ss ... where names an implementation as one of - mzscheme3m + mzscheme bigloo chicken gambit @@ -17,8 +17,8 @@ or any of the above prefixed by "no-" to skip the corresponding and benchmarks, run ./auto.ss --show -Naming no implementation/benchmark causes a standard of them to be run -(as reported by --show). Similarly, if the first named +Naming no implementation/benchmark causes a standard set of them to be +run (as reported by --show). Similarly, if the first named implementation/benchmak starts with "no-", the default set is used minus the "no-"-specified implementation/benchmark. @@ -36,7 +36,7 @@ All benchmarks must be run from the directory containing this file. Most bechmarks were obtained from http://www.cs.cmu.edu/afs/cs/project/ai-repository/ai/lang/scheme/code/bench/gabriel/ http://www.ccs.neu.edu/home/will/GC/sourcecode.html - Marc Feeley (who has all of them and more) + Marc Feeley Files that end in ".sch" are supposed to be standard Scheme plus `time'. Files that end in ".ss" are MzScheme wrapper modules or helper scripts. @@ -47,4 +47,4 @@ To build .sch directly with Gambit, Bigloo, or Chicken: mzscheme -qr mk-chicken.ss ; Unpack "dynamic-input.txt.gz" if you want to run the "dynamic" benchmark, -but the auto.ss script will do that for you. +but the "auto.ss" script will do that for you. diff --git a/collects/tests/mzscheme/benchmarks/common/auto.ss b/collects/tests/mzscheme/benchmarks/common/auto.ss index f3ad8439f5..5c1c61b84e 100755 --- a/collects/tests/mzscheme/benchmarks/common/auto.ss +++ b/collects/tests/mzscheme/benchmarks/common/auto.ss @@ -3,6 +3,8 @@ exec mzscheme -qu "$0" ${1+"$@"} |# +;; See "tabulate.ss" for information on the output format + (module auto scheme/base (require (for-syntax scheme/base) mzlib/process @@ -11,6 +13,8 @@ exec mzscheme -qu "$0" ${1+"$@"} mzlib/compile mzlib/inflate mzlib/date + mzlib/port + mzlib/file dynext/file syntax/toplevel scheme/runtime-path) @@ -34,10 +38,16 @@ exec mzscheme -qu "$0" ${1+"$@"} (delete-file (format "~a.o1" bm))) (define (mk-mzscheme bm) - ;; To get compilation time: - (parameterize ([current-namespace (make-base-namespace)]) - (namespace-require 'scheme/base) - (load (format "~a.ss" bm)))) + (unless (directory-exists? "compiled") + (make-directory "compiled")) + (parameterize ([current-namespace (make-base-namespace)] + [read-accept-reader #t]) + (let ([name (format "~a.ss" bm)]) + (compile-file name + (build-path "compiled" (path-add-suffix name #".zo")))))) + + (define (clean-up-zo bm) + (delete-directory/files "compiled")) (define (clean-up-nothing bm) (void)) @@ -71,21 +81,24 @@ exec mzscheme -qu "$0" ${1+"$@"} (eval '(define null #f)) ; for dynamic.sch (compile-file (format "~a.sch" bm)))) - (define (clean-up-zo bm) - (delete-file (build-path "compiled" (format "~a.zo" bm)))) + (define (setup-larceny bm) + (setup-sps bm "(larceny benchmarking)")) (define (mk-larceny bm) (parameterize ([current-input-port (open-input-string (format (string-append - "(compiler-switches 'fast-safe)\n" - "(compile-file \"~a.sch\")\n") + "(import (larceny compiler))\n" + "(compile-library \"~a.sls\")\n") bm))] [current-output-port (open-output-bytes)]) - (system "larceny"))) + (system "larceny -err5rs") + ;; Make sure compiled version is used: + (delete-file (format "~a.sls" bm)))) (define (clean-up-fasl bm) - (delete-file (format "~a.fasl" bm))) + (clean-up-sps bm) + (delete-file (format "~a.slfasl" bm))) (define (mk-mzc bm) (parameterize ([current-output-port (open-output-bytes)]) @@ -104,16 +117,128 @@ exec mzscheme -qu "$0" ${1+"$@"} (system (format "gsi -:d-,m10000 ~a.o1" bm))) (define (run-larceny bm) - (parameterize ([current-input-port (open-input-string - (format "(load \"~a.fasl\")\n" - bm))]) - (system "larceny"))) + (system "larceny -r6rs -program prog.sps -path .")) + (define (setup-sps bm lib) + (with-output-to-file "prog.sps" + #:exists 'truncate + (lambda () + (printf "(import (~a))\n" bm) + (printf "(bm-!-go)\n"))) + (with-output-to-file (format "~a.sls" bm) + #:exists 'truncate + (lambda () + (printf "(library (~a)\n" bm) + (printf " (export bm-!-go)\n") + (printf " (import (rnrs) (rnrs mutable-pairs) (rnrs mutable-strings) (rnrs r5rs) (rnrs eval) ~a)\n" lib) + (printf " (define (bm-!-go) 'ok)\n") + (call-with-input-file (format "~a.sch" bm) + (lambda (in) + (copy-port in (current-output-port)))) + (printf ")\n")))) + + (define (clean-up-sps bm) + (delete-file "prog.sps") + (let ([f (format "~a.sls" bm)]) + (when (file-exists? f) + (delete-file f)))) + + (define (setup-ikarus bm) + (setup-sps bm "(ikarus)") + (system "rm -rf ~/.ikarus")) + (define (mk-ikarus bm) - (void)) + (system "ikarus --compile-dependencies prog.sps")) (define (run-ikarus bm) - (system (format "ikarus ~a.sch < /dev/null" bm))) + (system "ikarus --r6rs-script prog.sps")) + + (define (clean-up-ikarus bm) + (clean-up-sps bm) + (system "rm -rf ~/.ikarus")) + + (define (run-scheme48 bm) + (parameterize ([current-input-port + (open-input-string + (format + ",bench on\n,open time bitwise\n,load \"scheme48-prelude.sch\"\n,load \"~a.sch\"\n,exit\n" + bm))]) + (system "scheme48 -h 20000000"))) + + (define (extract-scheme48-times bm str) + (let ([m (regexp-match #rx#"cpu time: ([0-9]+) real time: ([0-9]+)" str)] + ;; `time' result is 10s of milliseconds? OS ticks, maybe? + [msec/tick 10]) + (list (bytes->number (cadr m)) + (bytes->number (caddr m)) + 0))) + + (define (mk-mit bm) + (with-output-to-file (format "~a.scm" bm) + #:exists 'truncate + (lambda () + (printf "(declare (usual-integrations))\n") + (call-with-input-file "mit-prelude.sch" + (lambda (in) (copy-port in (current-output-port)))) + (call-with-input-file (format "~a.sch" bm) + (lambda (in) (copy-port in (current-output-port)))))) + (parameterize ([current-input-port + (open-input-string + (format "(cf \"~a\")\n" bm))] + [current-output-port (open-output-nowhere)]) + (system "mit-scheme"))) + + (define (run-mit bm) + (parameterize ([current-input-port + (open-input-string + (format "(load \"~a\")\n(exit)\ny\n" bm))]) + (system "mit-scheme --heap 12000"))) + + (define (clean-up-mit bm) + (delete-file (format "~a.com" bm)) + (delete-file (format "~a.ext" bm)) + (delete-file (format "~a.bci" bm)) + (delete-file (format "~a.bin" bm)) + (delete-file (format "~a.scm" bm))) + + (define (extract-mit-times bm str) + (let ([m (regexp-match #rx#"cpu: ([0-9]+) real: ([0-9]+) gc: ([0-9]+)" str)] + ;; `time' result is 10s of milliseconds? OS ticks, maybe? + [msec/tick 10]) + (list (bytes->number (cadr m)) + (bytes->number (caddr m)) + (bytes->number (cadddr m))))) + + (define (run-petite bm) + (parameterize ([current-input-port + (open-input-string + (format + "(load \"petite-prelude.sch\")\n(load \"~a.sch\")\n(exit)\n" + bm))]) + (system "petite"))) + + (define (extract-petite-times bm str) + (let ([m (regexp-match #rx#"([0-9]+) ms elapsed cpu time(?:, including ([0-9]+) ms collecting)?[ \n]* ([0-9]+) ms elapsed real time" str)]) + (list (bytes->number (cadr m)) + (bytes->number (cadddr m)) + (if (caddr m) (bytes->number (caddr m)) 0)))) + + (define (run-guile bm) + (parameterize ([current-input-port + (open-input-string + (format + "(load \"guile-prelude.sch\")\n(load \"~a.sch\")\n" + bm))]) + (system "guile"))) + + (define (extract-guile-times bm str) + (let ([m (regexp-match #rx#"user: ([0-9]+) system: ([0-9]+) real: ([0-9]+) gc: ([0-9]+)" str)] + ;; `time' result is 10s of milliseconds? OS ticks, maybe? + [msec/tick 10]) + (list (+ (bytes->number (cadr m)) + (bytes->number (caddr m))) + (bytes->number (cadddr m)) + (bytes->number (cadddr (cdr m)))))) (define (extract-times bm str) str) @@ -134,6 +259,15 @@ exec mzscheme -qu "$0" ${1+"$@"} (let ([m (regexp-match #rx#"cpu time: ([0-9]+) real time: ([0-9]+) gc time: ([0-9]+)" str)]) (map bytes->number (cdr m)))) + (define (extract-bigloo-times bm str) + (let ([m (regexp-match #rx#"real: ([0-9]+) sys: ([0-9]+) user: ([0-9]+)" str)] + ;; `time' result is 10s of milliseconds? OS ticks, maybe? + [msec/tick 10]) + (list (* msec/tick (+ (bytes->number (caddr m)) + (bytes->number (cadddr m)))) + (* msec/tick (bytes->number (cadr m))) + 0))) + (define (extract-larceny-times bm str) (let ([m (regexp-match #rx#"Elapsed time...: ([0-9]+) ms.*Elapsed GC time: ([0-9]+) ms" str)]) (list (bytes->number (cadr m)) @@ -162,14 +296,16 @@ exec mzscheme -qu "$0" ${1+"$@"} #"([0-9]*) ms elapsed cpu time, including ([0-9]*) ms collecting\n" #"[ \t]*([0-9]*) ms elapsed real time") str)]) - (list (string->number (bytes->string/utf-8 (cadr m))) - (string->number (bytes->string/utf-8 (cadddr m))) - (string->number (bytes->string/utf-8 (caddr m)))))) + (if m + (list (string->number (bytes->string/utf-8 (cadr m))) + (string->number (bytes->string/utf-8 (cadddr m))) + (string->number (bytes->string/utf-8 (caddr m)))) + (list #f #f #f)))) ;; Table of implementatons and benchmarks ------------------------------ - (define-struct impl (name make run extract-result clean-up skips)) + (define-struct impl (name setup make run extract-result clean-up skips)) (define mutable-pair-progs '(conform destruct @@ -183,34 +319,39 @@ exec mzscheme -qu "$0" ${1+"$@"} (define impls (list (make-impl 'mzscheme + void mk-mzscheme (lambda (bm) (system (format "mzscheme -u ~a.ss" bm))) extract-mzscheme-times - clean-up-nothing + clean-up-zo mutable-pair-progs) (make-impl 'mz-old + void mk-mzscheme (lambda (bm) (system (format "mz-old -u ~a.ss" bm))) extract-mzscheme-times - clean-up-nothing + clean-up-zo mutable-pair-progs) (make-impl 'mzschemecgc + void mk-mzscheme (lambda (bm) (system (format "mzschemecgc -u ~a.ss" bm))) extract-mzscheme-times - clean-up-nothing + clean-up-zo mutable-pair-progs) (make-impl 'mzscheme3m + void mk-mzscheme (lambda (bm) (system (format "mzscheme3m -u ~a.ss" bm))) extract-mzscheme-times - clean-up-nothing + clean-up-zo mutable-pair-progs) (make-impl 'plt-r5rs + void mk-plt-r5rs (lambda (bm) (system (format "plt-r5rs ~a.scm" bm))) @@ -218,6 +359,7 @@ exec mzscheme -qu "$0" ${1+"$@"} clean-up-plt-r5rs null) (make-impl 'mzc + void mk-mzc (lambda (bm) (system (format "mzscheme -mvqee '(load-extension \"~a\")' '(require ~a)'" @@ -228,20 +370,23 @@ exec mzscheme -qu "$0" ${1+"$@"} (append '(takr takr2) mutable-pair-progs)) (make-impl 'mzscheme-j + void mk-mzscheme (lambda (bm) (system (format "mzscheme -jqu ~a.ss" bm))) extract-mzscheme-times - clean-up-nothing + clean-up-zo mutable-pair-progs) (make-impl 'mzschemecgc-j + void mk-mzscheme (lambda (bm) (system (format "mzschemecgc -jqu ~a.ss" bm))) extract-mzscheme-times - clean-up-nothing + clean-up-zo mutable-pair-progs) (make-impl 'mzschemecgc-tl + void mk-mzscheme-tl (lambda (bm) (system (format "mzschemecgc -qr compiled/~a.zo" bm))) @@ -250,37 +395,71 @@ exec mzscheme -qu "$0" ${1+"$@"} (append '(nucleic2) mutable-pair-progs)) (make-impl 'chicken + void (run-mk "mk-chicken.ss") run-exe extract-chicken-times clean-up-bin - '(nucleic2)) + '(scheme2 takr2)) (make-impl 'bigloo + void (run-mk "mk-bigloo.ss") - run-exe/time - extract-time-times + run-exe + extract-bigloo-times clean-up-bin - '(cpstack maze maze2 puzzle triangle)) + '(cpstack takr2)) (make-impl 'gambit + void (run-mk "mk-gambit.ss") run-gambit-exe extract-gambit-times clean-up-o1 '(nucleic2)) (make-impl 'larceny + setup-larceny mk-larceny run-larceny extract-larceny-times clean-up-fasl '()) (make-impl 'ikarus + setup-ikarus mk-ikarus run-ikarus extract-ikarus-times - clean-up-nothing - '(fft)))) + clean-up-ikarus + '(takr)) + (make-impl 'mit + void + mk-mit + run-mit + extract-mit-times + clean-up-mit + '(nucleic2 puzzle takr2)) + (make-impl 'scheme48 + void + void + run-scheme48 + extract-scheme48-times + void + '()) + (make-impl 'petite + void + void + run-petite + extract-petite-times + void + '()) + (make-impl 'guile + void + void + run-guile + extract-guile-times + void + '(dynamic dynamic2)) +)) - (define obsolte-impls '(mzscheme mzscheme-j mzschemecgc-tl mzc mz-old)) + (define obsolte-impls '(mzscheme3m mzschemecgc mzscheme-j mzschemecgc-j mzschemecgc-tl mzc mz-old)) (define benchmarks '(conform @@ -303,6 +482,7 @@ exec mzscheme -qu "$0" ${1+"$@"} nboyer nestedloop nfa + nothing nqueens nucleic2 paraffins @@ -329,23 +509,25 @@ exec mzscheme -qu "$0" ${1+"$@"} impls)]) (if (memq bm (impl-skips i)) (rprintf "[~a ~a ~s #f]\n" impl bm '(#f #f #f)) - (let ([start (current-inexact-milliseconds)]) - ((impl-make i) bm) - (let ([end (current-inexact-milliseconds)]) - (let loop ([n num-iterations]) - (unless (zero? n) - (let ([out (open-output-bytes)]) - (unless (parameterize ([current-output-port out] - [current-error-port out]) - ((impl-run i) bm)) - (error 'auto "~a\nrun failed ~a" (get-output-bytes out) bm)) - (rprintf "[~a ~a ~s ~a]\n" - impl - bm - ((impl-extract-result i) bm (get-output-bytes out)) - (inexact->exact (round (- end start))))) - (loop (sub1 n))))) - ((impl-clean-up i) bm))) + (begin + ((impl-setup i) bm) + (let ([start (current-inexact-milliseconds)]) + ((impl-make i) bm) + (let ([end (current-inexact-milliseconds)]) + (let loop ([n num-iterations]) + (unless (zero? n) + (let ([out (open-output-bytes)]) + (unless (parameterize ([current-output-port out] + [current-error-port out]) + ((impl-run i) bm)) + (error 'auto "~a\nrun failed ~a" (get-output-bytes out) bm)) + (rprintf "[~a ~a ~s ~a]\n" + impl + bm + ((impl-extract-result i) bm (get-output-bytes out)) + (inexact->exact (round (- end start))))) + (loop (sub1 n))))) + ((impl-clean-up i) bm)))) (flush-output))) ;; Extract command-line arguments -------------------- diff --git a/collects/tests/mzscheme/benchmarks/common/bigloo-prelude.sch b/collects/tests/mzscheme/benchmarks/common/bigloo-prelude.sch index c0bc43003d..edb17f65ff 100644 --- a/collects/tests/mzscheme/benchmarks/common/bigloo-prelude.sch +++ b/collects/tests/mzscheme/benchmarks/common/bigloo-prelude.sch @@ -1,9 +1,16 @@ +(define orig-time time) + (define-macro (time expr) `(time-it (lambda () ,expr))) (define (time-it thunk) - (thunk)) + (multiple-value-bind (res rtime stime utime) + (orig-time thunk) + (print "real: " rtime " sys: " stime " user: " utime) + res)) (define (error . x) #f) - +(define bitwise-or bit-or) +(define bitwise-and bit-and) +(define bitwise-not bit-not) diff --git a/collects/tests/mzscheme/benchmarks/common/dderiv.sch b/collects/tests/mzscheme/benchmarks/common/dderiv.sch index bc01d9cac7..5e47a0b037 100644 --- a/collects/tests/mzscheme/benchmarks/common/dderiv.sch +++ b/collects/tests/mzscheme/benchmarks/common/dderiv.sch @@ -46,19 +46,13 @@ (define (f+dderiv a) (cons '+ (map dderiv a))) -(put '+ 'dderiv f+dderiv) ; install procedure on the property list - (define (f-dderiv a) (cons '- (map dderiv a))) -(put '- 'dderiv f-dderiv) ; install procedure on the property list - (define (*dderiv a) (list '* (cons '* a) (cons '+ (map dderiv-aux a)))) -(put '* 'dderiv *dderiv) ; install procedure on the property list - (define (/dderiv a) (list '- (list '/ @@ -71,8 +65,6 @@ (cadr a) (dderiv (cadr a)))))) -(put '/ 'dderiv /dderiv) ; install procedure on the property list - (define (dderiv a) (cond ((not (pair? a)) @@ -90,6 +82,14 @@ (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)) (dderiv '(+ (* 3 x x) (* a x x) (* b x) 5)))) +(put '+ 'dderiv f+dderiv) ; install procedure on the property list + +(put '- 'dderiv f-dderiv) ; install procedure on the property list + +(put '* 'dderiv *dderiv) ; install procedure on the property list + +(put '/ 'dderiv /dderiv) ; install procedure on the property list + ;;; call: (run) (time (run)) diff --git a/collects/tests/mzscheme/benchmarks/common/gambit-prelude.sch b/collects/tests/mzscheme/benchmarks/common/gambit-prelude.sch index 26f69d687a..bb9f3cc061 100644 --- a/collects/tests/mzscheme/benchmarks/common/gambit-prelude.sch +++ b/collects/tests/mzscheme/benchmarks/common/gambit-prelude.sch @@ -5,3 +5,4 @@ (safe) (interrupts-enabled) ) + diff --git a/collects/tests/mzscheme/benchmarks/common/guile-prelude.sch b/collects/tests/mzscheme/benchmarks/common/guile-prelude.sch new file mode 100644 index 0000000000..f9e61fb5d1 --- /dev/null +++ b/collects/tests/mzscheme/benchmarks/common/guile-prelude.sch @@ -0,0 +1,29 @@ + +(use-syntax (ice-9 syncase)) + +(define (msecs v) + (quotient (* v 1000) internal-time-units-per-second)) + +(define (time* thunk) + (let ((start (times)) + (start-gc (gc-run-time))) + (let ((v (thunk))) + (let ((end (times)) + (end-gc (gc-run-time))) + (display "user: ") + (display (msecs (- (tms:utime end) (tms:utime start)))) + (display " system: ") + (display (msecs (- (tms:stime end) (tms:stime start)))) + (display " real: ") + (display (msecs (- (tms:stime end) (tms:stime start)))) + (display " gc: ") + (display (msecs (- end-gc start-gc))) + (newline))))) + +(define-syntax time + (syntax-rules () + ((_ expr) (time* (lambda () expr))))) + +(define bitwise-and logand) +(define bitwise-ior logior) +(define bitwise-not lognot) \ No newline at end of file diff --git a/collects/tests/mzscheme/benchmarks/common/index-template.html b/collects/tests/mzscheme/benchmarks/common/index-template.html index ac12dd642c..7f49f71c0c 100644 --- a/collects/tests/mzscheme/benchmarks/common/index-template.html +++ b/collects/tests/mzscheme/benchmarks/common/index-template.html @@ -4,45 +4,64 @@

About the Benchmarks

-

The pages linked below show some benchmark results on a collection of fairly standard - (mostly Gabriel) Scheme benchmarks.

+

The benchmark results page shows some + benchmark results on a collection of fairly standard (mostly + Gabriel) Scheme benchmarks.

-

Tables show relative performance, with the actual time for the fastest - run shown on the left. So, by default, 1 - is the fastest, but select any implementation to normalize the table with - respect to that implementation's speed. A -- appears when a benchmark - didn't run in an implementation (and you should assume a benchmark problem, - rather than an implementation problem).

+

Tables show relative performance, with the actual time for the + fastest run shown on the left. So, by + default, 1 is the fastest, + but select any implementation to normalize the table with respect + to that implementation's speed. A - appears when a + benchmark didn't run in an implementation for some reason (possibly + not a good one).

-

Small gray numbers are (relative) compile times.

+

+The compilers-only page shows +just the compilers among the tested implementations. For those +results, the small gray numbers are (relative) compile times, where +the compile time for the nothing benchmark is subtracted from +every other benchmark's compile time.

-

Run times are averaged over three runs. All reported times are CPU time (system plus user). - Where available, the times are based on the output of the implementation's time - syntactic form, otherwise /usr/bin/time is used.

+

Run times are averaged over three runs for compilers or one run for + interpreters. All reported times are CPU time (system plus user). + The times are based on the output of the + implementation's time syntactic form or similar + functions.

-

Compiler configuration: +

Machine:

    -
  • Bigloo (2.8b): -06 -copt -O3 -copt -fomit-frame-pointer -
  • Chicken (2 build 3): -no-trace -no-lambda-info -optimize-level 3 -block -lambda-lift -
  • Gambit (4.0 beta 17): (declare (block) (standard-bindings) (extended-bindings) (safe) (interrupts-enabled)), - installed with --enable-single-host, compiled with -dynamic, compiled and run with -:m10000
    • -
  • Larceny (0.92b): default mode — but should use (benchmark-block-mode #t) when it works
    • -
  • MzScheme (352.5): in module
    • +
  • MacBook Pro, 2.53 GHz, Mac OS X 10.6.2, compiling to 32-bit programs +

+ +

Compiler configurations: +

    +
  • Bigloo (3.3a): -06 -call/cc -copt -O3 -copt -fomit-frame-pointer
    • +
  • Chicken (4.3.0): -no-trace -no-lambda-info -optimize-level 3 -block -lambda-lift
    • +
  • Gambit (4.6.0): (declare (block) (standard-bindings) (extended-bindings) (safe) (interrupts-enabled)), + compiled and run with -:m10000
    • +
  • Guile (1.8.7): load
    • +
  • Ikarus (0.0.4-rc1+ rev 1870): in R6RS library
    • +
  • Larceny (0.97): in R6RS library
    • +
  • MIT (7.7.90+): (declare (usual-integrations)); run with --heap 12000
    • +
  • Petite Chez (7.4d): load +
  • PLT (4.2.4): in module; for benchmarks that use set-car! and set-cdr!, + PLT's R5RS support is used
    • +
  • Scheme48 (1.8): load after ,bench on
-These configurations are all "safe mode", but they allow the compiler -to assume that built-in Scheme functions are not redefined and (except -in the case of Larceny) that no top-level defintion is ever -changed. Such assumptions correspond to putting the benchmark in an -R6RS library (we expect).

+These configurations are all “safe mode,” but they allow a +compiler to assume that built-in Scheme functions are not redefined +and that no top-level defintion is ever changed. Such assumptions +correspond to putting the benchmark in an R6RS library.

In general, we attempt to use the various implementations in a compentent way, but not in a sophisticated way. For example, we do not tweak inlining parameters or specify fixnum arithmetic (where appropriate), which could produce significant improvements from some compilers.

-

For a larger set of benchmarks and a more sophisticated use of the compilers, - see Marc Feeley's page: - http://www.iro.umontreal.ca/~gambit/bench.html. +

For more benchmarks and a more sophisticated use of a few compilers, + including fixnum- and flonum-specific arithmetic as well as unsafe modes, + see Gambit benchmark results.

For further details on the benchmarks here, see the benchmark source and infrastructure, which is available form the PLT SVN repository:

@@ -50,8 +69,3 @@ R6RS library (we expect).

http://svn.plt-scheme.org/plt/trunk/collects/tests/mzscheme/benchmarks/common/

-

Results

- - diff --git a/collects/tests/mzscheme/benchmarks/common/kanren.sch b/collects/tests/mzscheme/benchmarks/common/kanren.sch index 6f28c2c4bf..8d46a91dd8 100644 --- a/collects/tests/mzscheme/benchmarks/common/kanren.sch +++ b/collects/tests/mzscheme/benchmarks/common/kanren.sch @@ -1,5 +1,5 @@ -(define error - (lambda args (/ args))) +;; smashed into benchmark form by Matthew + (define errorf error) ; like cout << arguments << args @@ -14,7 +14,7 @@ (define cerr cout) (define pntall (lambda v (write v) (newline))) -(define (pretty-print v) (write v) (newline)) +(define (_pretty-print v) (write v) (newline)) (define nl (string #\newline)) @@ -113,14 +113,15 @@ (define-syntax test-check (syntax-rules () ((_ title tested-expression expected-result) - (begin - (cout "Testing " title nl) - (let* ((expected expected-result) - (produced tested-expression)) - (or (equal? expected produced) - (errorf 'test-check - "Failed: ~a~%Expected: ~a~%Computed: ~a~%" - 'tested-expression expected produced))))))) + (begin + (cout "Testing " title nl) + (let* ((expected expected-result) + (produced tested-expression)) + (or (equal? expected produced) + (errorf 'test-check + "Failed: ~a~%Expected: ~a~%Computed: ~a~%" + 'tested-expression expected produced))) + #f)))) (define symbol-append (lambda symbs @@ -149,7 +150,7 @@ (let ((id (logical-variable 'id)) ...) body)))) ; The anonymous variable -(define _ (let-lv (_) _)) +(define __ (let-lv (_) _)) ; Another way to introduce logical variables: via distinguished pairs ; (define logical-var-tag (list '*logical-var-tag*)) ; unique for eq? @@ -175,9 +176,14 @@ ; the exclamation mark. The mark makes sure the symbol stands out when ; printed. +(define counter 0) +(define (jensym s) + (set! counter (+ counter 1)) + (string->symbol (string-append "!$gen$!" s (number->string counter)))) + (define eigen-variable (lambda (id) - (symbol-append '! id '_ (gensym "x")))) + (symbol-append '! id '_ (jensym "x")))) (define eigen-var? (lambda (x) @@ -195,6 +201,7 @@ ((_ (id ...) body) (let ((id (eigen-variable 'id)) ...) body)))) +(define (eigen-test) (test-check 'eigen (and (eigen () #t) @@ -202,7 +209,7 @@ (eigen (x y) (begin (display "eigens: ") (display (list x y)) (newline) #t))) - #t) + #t)) ;;; ------------------------------------------------------ @@ -437,7 +444,7 @@ ;;;; This is Oleg's unifier ; Either t or u may be: -; _ +; __ ; free-var ; bound-var ; pair @@ -461,8 +468,8 @@ (lambda (t u subst) (cond ((eq? t u) subst) ; quick tests first - ((eq? t _) subst) - ((eq? u _) subst) + ((eq? t __) subst) + ((eq? u __) subst) ((var? t) (let*-and (unify-free/any t u subst) ((ct (assq t subst))) (if (var? u) ; ct is a bound var, u is a var @@ -505,13 +512,13 @@ ; Just like unify. However, the first term, t, comes from -; an internalized term. We know it can't be _ and can't contain _ +; an internalized term. We know it can't be __ and can't contain __ (define unify-internal/any (lambda (t u subst) (cond ((eq? t u) subst) ; quick tests first - ((eq? u _) subst) + ((eq? u __) subst) ((var? t) (let*-and (unify-free/any t u subst) ((ct (assq t subst))) (if (var? u) ; ct is a bound var, u is a var @@ -537,8 +544,8 @@ ; the other way around. ; Aside from the above, this function can take advantage of the following ; facts about (commitment->term cx) (where cx is an existing commitment): -; - it is never _ -; - it never contains _ +; - it is never __ +; - it never contains __ ; Most importantly, if, for example, (commitment->term ct) is a free variable, ; we enter its binding to (commitment->term cu) with fewer checks. ; in particular, we never need to call unify-free/list nor @@ -583,7 +590,7 @@ (define unify-free/any (lambda (t-var u subst) (cond - ((eq? u _) subst) + ((eq? u __) subst) ((var? u) (let*-and (extend-subst t-var u subst) ((cu (assq u subst))) (unify-free/bound t-var cu subst))) @@ -631,13 +638,13 @@ ; t-var is a free variable, u-value is a proper or improper ; list, which may be either fully or partially grounded (or not at all). -; We scan the u-value for _, and if, found, replace them with fresh +; We scan the u-value for __, and if, found, replace them with fresh ; variables. We then bind t-var to the term. ; This function is not recursive and always succeeds. ; -; We assume that more often than not u-value does not contain _. +; We assume that more often than not u-value does not contain __. ; Therefore, to avoid the wasteful rebuilding of u-value, we -; first scan it for the occurrence of _. If the scan returns negative, +; first scan it for the occurrence of __. If the scan returns negative, ; we can use u-value as it is. ; Rebuild lst replacing all anonymous variables with some @@ -647,7 +654,7 @@ (define ufl-rebuild-without-anons (lambda (lst) (cond - ((eq? lst _) (logical-variable '*anon)) + ((eq? lst __) (logical-variable '*anon)) ((not (pair? lst)) #f) ((null? (cdr lst)) (let ((new-car (ufl-rebuild-without-anons (car lst)))) @@ -670,7 +677,7 @@ (define (term-tests) - (cout nl "Compositions of substitutions" nl) + ; (cout nl "Compositions of substitutions" nl) ; (let-lv (x y) ; (test-check 'test-compose-subst-0 ; (append (unit-subst x y) (unit-subst y 52)) @@ -857,7 +864,7 @@ (list (let-lv (x0 x1 y0 y1) (begin - (pretty-print + (_pretty-print (reify-subst '() (unify `(h ,x1 (f ,y0 ,y0) ,y1) @@ -867,7 +874,7 @@ (let-lv (x0 x1 x2 y0 y1 y2) (begin - (pretty-print + (_pretty-print (reify-subst '() (unify `(h ,x1 ,x2 (f ,y0 ,y0) (f ,y1 ,y1) ,y2) @@ -877,7 +884,7 @@ (let-lv (x0 x1 x2 x3 x4 y0 y1 y2 y3 y4) (begin - (pretty-print + (_pretty-print (reify-subst '() (unify `(h ,x1 ,x2 ,x3 ,x4 (f ,y0 ,y0) (f ,y1 ,y1) (f ,y2 ,y2) (f ,y3 ,y3) ,y4) @@ -894,7 +901,8 @@ (reify-subst '() subst))) '((z.0 42) (y.0 (2 3 4 5 42)) (x.0 (1 2 3 4 5 42)))) ;'((z.0 . 42) (y.0 2 3 4 5 a*.0) (a*.0 . z.0) (x.0 1 2 3 4 5 a*.0))) - + + 10 ) @@ -915,18 +923,18 @@ (lambda (formal0) (lambda@ (formal1 formal2 ...) body0 body1 ...))))) -(define-syntax @ +(define-syntax at@ (syntax-rules () ((_ rator rand) (rator rand)) - ((_ rator rand0 rand1 rand2 ...) (@ (rator rand0) rand1 rand2 ...)))) + ((_ rator rand0 rand1 rand2 ...) (at@ (rator rand0) rand1 rand2 ...)))) -(test-check 'test-@-lambda@ - (@ (lambda@ (x y z) (+ x (+ y z))) 1 2 3) - 6) +;(test-check 'test-@-lambda@ +; (at@ (lambda@ (x y z) (+ x (+ y z))) 1 2 3) +; 6) -'(test-check 'test-@-lambda@ - (@ (lambda@ (x y z) (+ x (+ y z))) 1 2 3) - 42) +;'(test-check 'test-@-lambda@ +; (at@ (lambda@ (x y z) (+ x (+ y z))) 1 2 3) +; 42) (define Y (lambda (f) @@ -959,7 +967,7 @@ ; Trivial goals -(define succeed (lambda@ (s k) (@ k s))) ; eta-reduced +(define succeed (lambda@ (s k) (at@ k s))) ; eta-reduced (define fail (lambda@ (s k f) (f))) (define sfail (lambda@ (k f) (f))) ; Failed SGoal @@ -1085,16 +1093,16 @@ ; ((_ (ex-id) gl) ; (let-lv (ex-id) ; (lambda@ (sk fk in-subst) -; (@ gl +; (at@ gl ; (lambda@ (fk out-subst) -; (@ sk fk (lv-elim-1 ex-id in-subst out-subst))) +; (at@ sk fk (lv-elim-1 ex-id in-subst out-subst))) ; fk in-subst)))) ; ((_ (ex-id ...) gl) ; (let-lv (ex-id ...) ; (lambda@ (sk fk in-subst) -; (@ gl +; (at@ gl ; (lambda@ (fk out-subst) -; (@ sk fk (lv-elim (list ex-id ...) in-subst out-subst))) +; (at@ sk fk (lv-elim (list ex-id ...) in-subst out-subst))) ; fk in-subst)))))) ; For the unifier that doesn't introduce temp variables, @@ -1117,7 +1125,7 @@ ; So, to prune variables and preserve sharing, we have to topologically sort ; the bindings first! -(define-syntax exists +(define-syntax _exists (syntax-rules () ((_ () gl) gl) ((_ (ex-id ...) gl) @@ -1142,13 +1150,13 @@ (let ((print-it (lambda (event subst) (display title) (display " ") - (display event) (pretty-print subst) (newline)))) + (display event) (_pretty-print subst) (newline)))) (lambda@ (subst sk fk) (print-it "CALL:" subst) - (@ gl subst + (at@ gl subst (lambda@ (subst fk) (print-it "RETURN:" subst) - (@ sk subst + (at@ sk subst (lambda () (display title) (display " REDO") (newline) (fk)) @@ -1182,9 +1190,9 @@ (define-syntax splice-in-gls/all (syntax-rules () - ((_ subst sk gl) (@ gl subst sk)) + ((_ subst sk gl) (at@ gl subst sk)) ((_ subst sk gl0 gl1 ...) - (@ gl0 subst (lambda (subst) (splice-in-gls/all subst sk gl1 ...)))))) + (at@ gl0 subst (lambda (subst) (splice-in-gls/all subst sk gl1 ...)))))) ; (promise-one-answer gl) @@ -1226,9 +1234,9 @@ ((_ gl0 gl1 ...) (promise-one-answer (lambda@ (subst sk fk) - (@ + (at@ (splice-in-gls/all subst - (lambda@ (subst fk-ign) (@ sk subst fk)) gl0 gl1 ...) + (lambda@ (subst fk-ign) (at@ sk subst fk)) gl0 gl1 ...) fk)))))) ; (all!! gl1 gl2 ...) @@ -1252,11 +1260,11 @@ (define-syntax splice-in-gls/all!! (syntax-rules (promise-one-answer) ((_ subst sk fk) - (@ sk subst fk)) + (at@ sk subst fk)) ((_ subst sk fk (promise-one-answer gl)) - (@ gl subst sk fk)) + (at@ gl subst sk fk)) ((_ subst sk fk gl0 gl1 ...) - (@ gl0 subst + (at@ gl0 subst (lambda@ (subst fk-ign) (splice-in-gls/all!! subst sk fk gl1 ...)) fk)))) @@ -1288,16 +1296,16 @@ (syntax-rules () ((_ condition then) (lambda@ (subst sk fk) - (@ condition subst + (at@ condition subst ; sk from cond - (lambda@ (subst fk-ign) (@ then subst sk fk)) + (lambda@ (subst fk-ign) (at@ then subst sk fk)) ; failure from cond fk))) ((_ condition then else) (lambda@ (subst sk fk) - (@ condition subst - (lambda@ (subst fk-ign) (@ then subst sk fk)) - (lambda () (@ else subst sk fk)) + (at@ condition subst + (lambda@ (subst fk-ign) (at@ then subst sk fk)) + (lambda () (at@ else subst sk fk)) ))))) ; (if-all! (COND1 ... CONDN) THEN) @@ -1354,9 +1362,9 @@ (define-syntax splice-in-gls/any (syntax-rules () - ((_ subst sk fk gl1) (@ gl1 subst sk fk)) + ((_ subst sk fk gl1) (at@ gl1 subst sk fk)) ((_ subst sk fk gl1 gl2 ...) - (@ gl1 subst sk (lambda () (splice-in-gls/any subst sk fk gl2 ...)))))) + (at@ gl1 subst sk (lambda () (splice-in-gls/any subst sk fk gl2 ...)))))) ; Negation @@ -1373,16 +1381,16 @@ (define fails (lambda (gl) (lambda@ (subst sk fk) - (@ gl subst + (at@ gl subst (lambda@ (subst current-fk) (fk)) - (lambda () (@ sk subst fk)) + (lambda () (at@ sk subst fk)) )))) ; Again, G-Rule must hold for this predicate to be logically sound (define succeeds (lambda (gl) (lambda@ (subst sk fk) - (@ gl subst (lambda@ (subst-ign fk-ign) (@ sk subst fk)) + (at@ gl subst (lambda@ (subst-ign fk-ign) (at@ sk subst fk)) fk)))) ; partially-eval-sgl: Partially evaluate a semi-goal. A @@ -1396,7 +1404,7 @@ ; be implemented with streams (lazy lists). The following is a purely ; combinational implementation. ; -; (@ partially-eval-sgl sgl a b) => +; (at@ partially-eval-sgl sgl a b) => ; (b) if sgl has no answers ; (a s residial-sgl) if sgl has a answer. That answer is delivered ; in s. @@ -1406,14 +1414,14 @@ ; The following definition is eta-reduced. (define (partially-eval-sgl sgl) - (@ sgl + (at@ sgl (lambda@ (subst fk a b) - (@ a subst + (at@ a subst (lambda@ (sk1 fk1) - (@ + (at@ (fk) ; new a - (lambda@ (sub11 x) (@ sk1 sub11 (lambda () (@ x sk1 fk1)))) + (lambda@ (sub11 x) (at@ sk1 sub11 (lambda () (at@ x sk1 fk1)))) ; new b fk1)))) (lambda () (lambda@ (a b) (b))))) @@ -1444,16 +1452,16 @@ ((null? sgls) (fk)) ; all of the sgls are finished ((null? (cdr sgls)) ; only one of sgls left -- run it through the end - (@ (car sgls) sk fk)) + (at@ (car sgls) sk fk)) (else (let loop ((curr sgls) (residuals '())) ; check if the current round is finished (if (null? curr) (interleave sk fk (reverse residuals)) - (@ + (at@ partially-eval-sgl (car curr) ; (car curr) had an answer (lambda@ (subst residual) - (@ sk subst + (at@ sk subst ; re-entrance cont (lambda () (loop (cdr curr) (cons residual residuals))))) ; (car curr) is finished - drop it, and try next @@ -1505,13 +1513,13 @@ (cond ((null? sagls) (fk)) ; all of the sagls are finished ((null? (cdr sagls)) ; only one gl is left -- run it through the end - (@ (caar sagls) sk fk)) + (at@ (caar sagls) sk fk)) (else (let loop ((curr sagls) (residuals '())) ; check if the current round is finished (if (null? curr) (outer (reverse residuals)) - (@ + (at@ partially-eval-sgl (caar curr) ; (caar curr) had an answer (lambda@ (subst residual) @@ -1519,12 +1527,12 @@ ; gls down the curr. (let check ((to-check (cdr curr))) (if (null? to-check) ; OK, subst is unique,give it to user - (@ sk subst + (at@ sk subst ; re-entrance cont (lambda () (loop (cdr curr) (cons (cons residual (cdar curr)) residuals)))) - (@ (cdar to-check) subst + (at@ (cdar to-check) subst ; subst was the answer to some other gl: ; check failed (lambda@ (subst1 fk1) @@ -1575,13 +1583,13 @@ ((_ condition then) (all condition then)) ((_ condition then else) (lambda@ (subst sk fk) - (@ partially-eval-sgl (condition subst) + (at@ partially-eval-sgl (condition subst) (lambda@ (ans residual) - (@ then ans sk + (at@ then ans sk ; then failed. Check to see if condition has another answer - (lambda () (@ residual (lambda@ (subst) (@ then subst sk)) fk)))) + (lambda () (at@ residual (lambda@ (subst) (at@ then subst sk)) fk)))) ; condition failed - (lambda () (@ else subst sk fk))))))) + (lambda () (at@ else subst sk fk))))))) ; An interleaving conjunction: all-interleave @@ -1675,11 +1683,11 @@ (define all-interleave-bin (lambda (sgl1 gl2) (lambda@ (sk fk) - (@ partially-eval-sgl sgl1 + (at@ partially-eval-sgl sgl1 (lambda@ (ans residual) (interleave sk fk (list - (@ gl2 ans) + (at@ gl2 ans) (all-interleave-bin residual gl2) ))) ;gl1 failed @@ -1725,21 +1733,21 @@ ; we notice that the logical variable 'x' occurs at the top-level. Normally we ; compile the relation like that into the following ; (lambda (g1 g2) -; (exists (x y) +; (_exists (x y) ; (lambda@ (subst) ; (let*-and (fail subst) ((subst (unify g1 `(,x . ,y) subst)) ; (subst (unify g2 x subst))) -; (@ body subst))))) +; (at@ body subst))))) ; ; However, that we may permute the order of 'unify g...' clauses ; to read ; (lambda (g1 g2) -; (exists (x y) +; (_exists (x y) ; (lambda@ (subst) ; (let*-and (fail subst) ((subst (unify x g2 subst)) ; (subst (unify g1 `(,x . ,y) subst)) ; ) -; (@ body subst))))) +; (at@ body subst))))) ; ; We may further note that according to the properties of the unifier ; (see below), (unify x g2 subst) must always succeed, @@ -1751,7 +1759,7 @@ ; to being lexical. Thus, we compile the relation as ; ; (lambda (g1 g2) -; (exists (x y) +; (_exists (x y) ; (lambda@ (subst) ; (let* ((subst (unify-free/any x g2 subst)) ; (fast-path? (and (pair? subst) @@ -1760,14 +1768,14 @@ ; (subst (if fast-path? (cdr subst) subst))) ; (let*-and sfail ((subst (unify g1 `(,x . ,y) subst)) ; ) -; (@ body subst)))))) +; (at@ body subst)))))) ; ; The benefit of that approach is that we limit the growth of subst and avoid ; keeping commitments that had to be garbage-collected later. (define-syntax relation - (syntax-rules (to-show head-let once _) + (syntax-rules (to-show head-let once __) ((_ (head-let head-term ...) gl) (relation-head-let (head-term ...) gl)) ((_ (head-let head-term ...)) ; not particularly useful without body @@ -1794,7 +1802,7 @@ ; parameters, and forget them ; also, note and keep track of the first occurrence of a term ; that is just a var (bare-var) - ((_ "g" vars once-vars (gs ...) gunis bvars bvar-cl (_ . terms) . gl) + ((_ "g" vars once-vars (gs ...) gunis bvars bvar-cl (__ . terms) . gl) (relation "g" vars once-vars (gs ... anon) gunis bvars bvar-cl terms . gl)) ((_ "g" vars once-vars (gs ...) gunis bvars (subst . cls) @@ -1830,20 +1838,20 @@ ; Final: writing the code ((_ "f" vars () () () (subst) gl) ; no arguments (no head-tests) (lambda () - (exists vars gl))) + (_exists vars gl))) ; no tests but pure binding ((_ "f" (ex-id ...) once-vars (g ...) () (subst) gl) (lambda (g ...) - (exists (ex-id ...) gl))) + (_exists (ex-id ...) gl))) ; the most general ((_ "f" (ex-id ...) once-vars (g ...) ((gv . term) ...) (subst let*-clause ...) gl) (lambda (g ...) - (exists (ex-id ...) + (_exists (ex-id ...) (lambda (subst) (let* (let*-clause ...) (let*-and sfail ((subst (unify gv term subst)) ...) - (@ gl subst))))))))) + (at@ gl subst))))))))) ; A macro-expand-time memv function for identifiers ; id-memv?? FORM (ID ...) KT KF @@ -1948,14 +1956,14 @@ (lambda gvs ; don't bother bind vars (lambda@ (subst) (let*-and sfail ((subst (unify gv term subst)) ...) - (@ succeed subst))))) + (at@ succeed subst))))) ((_ "f" (var0 ...) ((gvo term) ...) gvs gl) (lambda gvs (lambda@ (subst) ; first unify the constants (let*-and sfail ((subst (unify gvo term subst)) ...) - (let ((var0 (if (eq? var0 _) (logical-variable '?) var0)) ...) - (@ gl subst)))))))) + (let ((var0 (if (eq? var0 __) (logical-variable '?) var0)) ...) + (at@ gl subst)))))))) ; (define-syntax relation/cut ; (syntax-rules (to-show) @@ -1965,11 +1973,11 @@ ; (relation/cut cut-id ex-ids (var ... g) (x1 ...) xs gl ...)) ; ((_ cut-id (ex-id ...) (g ...) () (x ...) gl ...) ; (lambda (g ...) -; (exists (ex-id ...) +; (_exists (ex-id ...) ; (all! (== g x) ... ; (lambda@ (sk fk subst cutk) ; (let ((cut-id (!! cutk))) -; (@ (all gl ...) sk fk subst cutk))))))))) +; (at@ (all gl ...) sk fk subst cutk))))))))) (define-syntax fact (syntax-rules () @@ -2043,9 +2051,9 @@ ; Unify lifted to be a binary relation (define-syntax == - (syntax-rules (_) - ((_ _ u) (lambda@ (subst sk) (@ sk subst))) - ((_ t _) (lambda@ (subst sk) (@ sk subst))) + (syntax-rules (__) + ((_ __ u) (lambda@ (subst sk) (at@ sk subst))) + ((_ t __) (lambda@ (subst sk) (at@ sk subst))) ((_ t u) (lambda@ (subst) (let*-and sfail ((subst (unify t u subst))) @@ -2071,7 +2079,7 @@ (syntax-rules () ((_ (redo-k subst id ...) A SE ...) (let-lv (id ...) - (@ A empty-subst + (at@ A empty-subst (lambda@ (subst redo-k) SE ...) (lambda () '())))))) @@ -2104,14 +2112,14 @@ ((_ (var ...) gl) (lambda@ (subst) (let ((var (nonvar! (subst-in var subst))) ...) - (@ gl subst)))))) + (at@ gl subst)))))) (define-syntax project/no-check (syntax-rules () ((_ (var ...) gl) (lambda@ (subst) (let ((var (subst-in var subst)) ...) - (@ gl subst)))))) + (at@ gl subst)))))) (define-syntax predicate (syntax-rules () @@ -2187,10 +2195,10 @@ sfail (let ((s (extend-subst depth-counter-var (+ counter 1) subst))) - (@ gl s)))))) + (at@ gl s)))))) (else (let ((s (extend-subst depth-counter-var 1 subst))) - (@ gl s))))))))) + (at@ gl s))))))))) )) ; ?- help(call_with_depth_limit/3). @@ -2241,7 +2249,7 @@ ) (test-check 'test-father0 (let ((result - (@ (father 'jon 'sam) empty-subst + (at@ (father 'jon 'sam) empty-subst initial-sk initial-fk))) (and (equal? (car result) '()) @@ -2250,7 +2258,7 @@ (test-check 'test-child-of-male-0 (reify-subst '() - (car (@ (child-of-male 'sam 'jon) empty-subst + (car (at@ (child-of-male 'sam 'jon) empty-subst initial-sk initial-fk))) ;`(,(commitment 'child.0 'sam) ,(commitment 'dad.0 'jon))) '()) ; variables shouldn't leak @@ -2259,7 +2267,7 @@ ; The mark should be found here... (test-check 'test-child-of-male-1 (reify-subst '() - (car (@ (child-of-male 'sam 'jon) empty-subst + (car (at@ (child-of-male 'sam 'jon) empty-subst initial-sk initial-fk))) ;`(,(commitment 'child.0 'sam) ,(commitment 'dad.0 'jon))) '()) @@ -2282,7 +2290,7 @@ ) (test-check 'test-father-1 (let ((result - (@ (new-father 'rob 'sal) empty-subst + (at@ (new-father 'rob 'sal) empty-subst initial-sk initial-fk))) (and (equal? (car result) '()) @@ -2310,7 +2318,7 @@ (test-check 'test-father-5 (query (redok subst x) (newer-father 'rob x) - (pretty-print subst) + (_pretty-print subst) (cons (reify-subst (list x) subst) (redok))) @@ -2394,7 +2402,7 @@ ((grandpa-sam (relation (grandchild) (to-show grandchild) - (exists (parent) + (_exists (parent) (all (father 'sam parent) (father parent grandchild)))))) (test-check 'test-grandpa-sam-1 @@ -2406,7 +2414,7 @@ ((grandpa-sam (relation ((once grandchild)) (to-show grandchild) - (exists (parent) + (_exists (parent) (all (father 'sam parent) (father parent grandchild)))))) (test-check 'test-grandpa-sam-1 @@ -2429,7 +2437,7 @@ (let ((grandpa (relation ((once grandad) (once grandchild)) (to-show grandad grandchild) - (exists (parent) + (_exists (parent) (all (father grandad parent) (father parent grandchild)))))) @@ -2441,7 +2449,7 @@ (lambda (guide* grandad*) (relation (grandchild) (to-show grandchild) - (exists (parent) + (_exists (parent) (all (guide* grandad* parent) (guide* parent grandchild))))))) @@ -2472,14 +2480,14 @@ ((grandpa/father (relation (grandad grandchild) (to-show grandad grandchild) - (exists (parent) + (_exists (parent) (all (father grandad parent) (father parent grandchild))))) (grandpa/mother (relation (grandad grandchild) (to-show grandad grandchild) - (exists (parent) + (_exists (parent) (all (father grandad parent) (mother parent grandchild))))) @@ -2496,7 +2504,7 @@ ((grandpa-sam (let ((r (relation (child) (to-show child) - (exists (parent) + (_exists (parent) (all (father 'sam parent) (father parent child)))))) @@ -2513,7 +2521,7 @@ ; (define grandpa/father ; (relation/cut cut (grandad grandchild) ; (to-show grandad grandchild) - ; (exists (parent) + ; (_exists (parent) ; (all ; (father grandad parent) ; (father parent grandchild) @@ -2522,7 +2530,7 @@ ; (define grandpa/mother ; (relation (grandad grandchild) ; (to-show grandad grandchild) - ; (exists (parent) + ; (_exists (parent) ; (all ; (father grandad parent) ; (mother parent grandchild))))) @@ -2533,7 +2541,7 @@ ((grandpa/father (relation (grandad grandchild) (to-show grandad grandchild) - (exists (parent) + (_exists (parent) (all! (father grandad parent) (father parent grandchild))))) @@ -2541,7 +2549,7 @@ (grandpa/mother (relation (grandad grandchild) (to-show grandad grandchild) - (exists (parent) + (_exists (parent) (all (father grandad parent) (mother parent grandchild))))) @@ -2560,21 +2568,21 @@ ; (define grandpa/father ; (relation/cut cut (grandad grandchild) ; (to-show grandad grandchild) - ; (exists (parent) + ; (_exists (parent) ; (all cut (father grandad parent) (father parent grandchild))))) (let ((grandpa/father (relation (grandad grandchild) (to-show grandad grandchild) - (exists (parent) + (_exists (parent) (all (father grandad parent) (father parent grandchild))))) (grandpa/mother (relation (grandad grandchild) (to-show grandad grandchild) - (exists (parent) + (_exists (parent) (all (father grandad parent) (mother parent grandchild))))) ) @@ -2638,7 +2646,7 @@ ((a-grandma (relation (grandad grandchild) (to-show grandad grandchild) - (exists (parent) + (_exists (parent) (all! (mother grandad parent))))) (no-grandma-grandpa (let-gls (a1 a2) ((a-grandma a-grandma) @@ -2671,14 +2679,14 @@ (let* ((parents-of-scouts-sgl ((parents-of-scouts p1 p2) empty-subst)) (cons@ (lambda@ (x y) (cons x y))) - (split1 (@ + (split1 (at@ partially-eval-sgl parents-of-scouts-sgl cons@ (lambda () '()))) (a1 (car split1)) - (split2 (@ partially-eval-sgl (cdr split1) cons@ + (split2 (at@ partially-eval-sgl (cdr split1) cons@ (lambda () '()))) (a2 (car split2)) - (split3 (@ partially-eval-sgl (cdr split2) cons@ + (split3 (at@ partially-eval-sgl (cdr split2) cons@ (lambda () '()))) (a3 (car split3))) (map (lambda (subst) @@ -2730,7 +2738,7 @@ (lambda (old young) (any (father old young) - (exists (not-so-old) + (_exists (not-so-old) (all (father old not-so-old) (ancestor not-so-old young))))))) @@ -2749,7 +2757,7 @@ (letrec ((move (extend-relation (a1 a2 a3 a4) - (fact () 0 _ _ _) + (fact () 0 __ __ __) (relation (n a b c) (to-show n a b c) (project (n) @@ -2788,7 +2796,7 @@ (letrec ((move (extend-relation (a1 a2 a3 a4) - (fact () 0 _ _ _) + (fact () 0 __ __ __) (relation (n a b c) (to-show n a b c) (project (n) @@ -2841,7 +2849,7 @@ (test-check 'unification-of-free-vars-4 (solve 1 (x) - (exists (y) + (_exists (y) (all! (== y x) (== y 5) (== x y)))) '(((x.0 5)))) @@ -2928,8 +2936,8 @@ ; (test-check 'lv-elim-1 ; (reify ; (let-lv (x z dummy) - ; (@ - ; (exists (y) + ; (at@ + ; (_exists (y) ; (== `(,x ,z ,y) `(5 9 ,x))) ; (lambda@ (fk subst) subst) ; initial-fk @@ -2940,8 +2948,8 @@ ; (test-check 'lv-elim-2 ; (reify ; (let-lv (x dummy) - ; (@ - ; (exists (y) + ; (at@ + ; (_exists (y) ; (== `(,x ,y) `((5 ,y) ,7))) ; (lambda@ (fk subst) subst) ; initial-fk @@ -2953,8 +2961,8 @@ ; (test-check 'lv-elim-3 ; (reify ; (let-lv (x v dummy) - ; (@ - ; (exists (y) + ; (at@ + ; (_exists (y) ; (== x `(a b c ,v d))) ; (lambda@ (fk subst) subst) ; initial-fk @@ -2966,7 +2974,7 @@ ; (test-check 'lv-elim-4-1 ; (reify ; (let-lv (x v b dummy) - ; (@ + ; (at@ ; (let-lv (y) ; (== `(,b ,x ,y) `(,x ,y 1))) ; (lambda@ (fk subst) subst) @@ -2977,9 +2985,9 @@ ; ; (test-check 'lv-elim-4-2 ; ; (concretize ; ; (let-lv (v b dummy) - ; ; (@ - ; ; (exists (x) - ; ; (exists (y) + ; ; (at@ + ; ; (_exists (x) + ; ; (_exists (y) ; ; (== `(,b ,x ,y) `(,x ,y 1)))) ; ; (lambda@ (fk subst) subst) ; ; initial-fk @@ -2989,9 +2997,9 @@ ; ; (test-check 'lv-elim-4-3 ; ; (concretize ; ; (let-lv (v b dummy) - ; ; (@ - ; ; (exists (y) - ; ; (exists (x) + ; ; (at@ + ; ; (_exists (y) + ; ; (_exists (x) ; ; (== `(,b ,x ,y) `(,x ,y 1)))) ; ; (lambda@ (fk subst) subst) ; ; initial-fk @@ -3001,8 +3009,8 @@ ; (test-check 'lv-elim-4-4 ; (reify ; (let-lv (v b dummy) - ; (@ - ; (exists (x y) + ; (at@ + ; (_exists (x y) ; (== `(,b ,x ,y) `(,x ,y 1))) ; (lambda@ (fk subst) subst) ; initial-fk @@ -3015,7 +3023,7 @@ ; (test-check 'lv-elim-5-1 ; (reify ; (let-lv (x v b dummy) - ; (@ + ; (at@ ; (let-lv (y) ; (== `(,b ,y ,x) `(,x (1 ,x) ,y))) ; (lambda@ (fk subst) subst) @@ -3027,9 +3035,9 @@ ; ; (test-check 'lv-elim-5-2 ; ; (concretize ; ; (let-lv (v b dummy) - ; ; (@ - ; ; (exists (x) - ; ; (exists (y) + ; ; (at@ + ; ; (_exists (x) + ; ; (_exists (y) ; ; (== `(,b ,y ,x) `(,x (1 ,x) ,y)))) ; ; (lambda@ (fk subst) subst) ; ; initial-fk @@ -3039,9 +3047,9 @@ ; ; (test-check 'lv-elim-5-3 ; ; (concretize ; ; (let-lv (v b dummy) - ; ; (@ - ; ; (exists (y) - ; ; (exists (x) + ; ; (at@ + ; ; (_exists (y) + ; ; (_exists (x) ; ; (== `(,b ,y ,x) `(,x (1 ,x) ,y)))) ; ; (lambda@ (fk subst) subst) ; ; initial-fk @@ -3051,8 +3059,8 @@ ; (test-check 'lv-elim-5-4 ; (reify ; (let-lv (v b dummy) - ; (@ - ; (exists (x y) + ; (at@ + ; (_exists (x y) ; (== `(,b ,y ,x) `(,x (1 ,x) ,y))) ; (lambda@ (fk subst) subst) ; initial-fk @@ -3094,19 +3102,19 @@ ) (cout nl "R1:" nl) - (pretty-print (solve 10 (x y) (R1 x y))) + (_pretty-print (solve 10 (x y) (R1 x y))) (cout nl "R2:" nl) - (pretty-print (solve 10 (x y) (R2 x y))) + (_pretty-print (solve 10 (x y) (R2 x y))) (cout nl "R1+R2:" nl) - (pretty-print + (_pretty-print (solve 10 (x y) ((extend-relation (a1 a2) R1 R2) x y))) (cout nl "Rinf:" nl) - (values (pretty-print (solve 5 (x y) (Rinf x y)))) + (values (_pretty-print (solve 5 (x y) (Rinf x y)))) (cout nl "Rinf+R1: Rinf starves R1:" nl) (values - (pretty-print + (_pretty-print (solve 5 (x y) ((extend-relation (a1 a2) Rinf R1) x y)))) @@ -3393,7 +3401,8 @@ ((x.0 (succ (succ (succ (succ (succ zero)))))) (y.0 zero)))) (newline) - )) + ) +10) ;; ======================================================================== ;; type-inference example @@ -3418,7 +3427,7 @@ ; ; $Id: type-inference.scm,v 4.50 2005/02/12 00:05:01 oleg Exp $ -(display "Type inference") (newline) +; (display "Type inference") (newline) ; Variation 1: use a subset of Scheme itself as the source language ; The following two functions translate between the source language @@ -3529,12 +3538,12 @@ (define env (relation (head-let g v t) - (exists (tq) + (_exists (tq) (all!! (membero `(,v . ,tq) g) (any (== tq `(non-generic ,t)) - (exists (type-gen) + (_exists (type-gen) (all!! (== tq `(generic ,type-gen)) (project (type-gen) @@ -3584,7 +3593,7 @@ (define app-rel (relation (g t rand rator) (to-show g `(app ,rator ,rand) t) - (exists (t-rand) + (_exists (t-rand) (all!! (!- g rator `(a--> ,t-rand ,t)) (!- g rand t-rand))))) (define fix-rel @@ -3606,7 +3615,7 @@ (relation (g v rand body t) (to-show g `(let ((,v ,rand)) ,body) t) (all!! - (exists (some-type) (!- g rand some-type)) + (_exists (some-type) (!- g rand some-type)) (!- `((,v generic ,(relation (head-let t-rand) (all!! (!- g rand t-rand) @@ -3819,7 +3828,9 @@ (t.0 a-->) (u.0 int) (v.0 int)))) - #t)) + #t) + +10) ;---------------------------------------------------------------------- ; A different implementation of type environments @@ -3834,7 +3845,7 @@ ; !- as the argument. Actually, they will receive the 'self'-like ; argument. We need to explicitly find the fixpoint. -(cout nl "Natural-deduction-like type inference" nl nl) +; (cout nl "Natural-deduction-like type inference" nl nl) (define pint-rel @@ -3893,7 +3904,7 @@ (let ((!- (s!- s!-))) (relation (t rand rator) (to-show `(app ,rator ,rand) t) - (exists (t-rand) + (_exists (t-rand) (all!! (!- rator `(a--> ,t-rand ,t)) (!- rand t-rand))))))) (define pfix-rel @@ -3919,7 +3930,7 @@ (relation (v rand body t) (to-show `(let ((,v ,rand)) ,body) t) (all!! - (exists (some-type) (!- rand some-type)) + (_exists (some-type) (!- rand some-type)) (let* ((snew-!- (lambda (self) (extend-relation (v t) @@ -4144,7 +4155,8 @@ (t.0 a-->) (u.0 int) (v.0 int)))) - #t)) + #t) +10) ; The code below uses the low-level function var? Every use of var? @@ -4217,15 +4229,16 @@ (equal? (solution (x) (name x '(115 108 101 101 112))) '((x.0 sleep)))) - #t)) + #t) +10) ;; ======================================================================== ;; typeclasses example ;; ======================================================================== -(newline) -(display "Checking for dependency satisfaction in Haskell typeclasses") -(newline) +;(newline) +;(display "Checking for dependency satisfaction in Haskell typeclasses") +;(newline) ; Suppose we have the following Haskell class and instance declarations ; class C a b c | a b -> c ; instance C a b c => C a (x,y,b) c @@ -4261,10 +4274,10 @@ (fails (project/no-check (c1 c2) (predicate (*equal? c1 c2))))))) ; This does loop -'(define typeclass-C - (extend-relation (a b c) - typeclass-C-instance-1 - typeclass-C-instance-2)) +;'(define typeclass-C +; (extend-relation (a b c) +; typeclass-C-instance-1 +; typeclass-C-instance-2)) (define typeclass-C/x (extend-relation-with-recur-limit 2 (a b c) @@ -4359,13 +4372,15 @@ (test-check "Typechecking (open world) f [x] int" (solve 4 (a) (typeclass-F-instance-1 `(list ,a) 'int)) '()) ; meaning: does not typecheck! + + 10 ) ;; ======================================================================== ;; zebra example ;; ======================================================================== -(display "Zebra") (newline) +; (display "Zebra") (newline) ; 1. There are five houses in a row, each of a different color ; and inhabited by men of different nationalities, @@ -4392,9 +4407,9 @@ (define memb (relation (head-let item lst) - (any (== lst `(,item . ,_)) - (exists (rest) - (if-only (== lst `(,_ . ,rest)) (memb item rest)))))) + (any (== lst `(,item . ,__)) + (_exists (rest) + (if-only (== lst `(,__ . ,rest)) (memb item rest)))))) (define next-to @@ -4403,38 +4418,38 @@ (define on-right (extend-relation (a0 a1 a2) - (fact (item1 item2) item1 item2 `(,item1 ,item2 . ,_)) + (fact (item1 item2) item1 item2 `(,item1 ,item2 . ,__)) (relation ((once item1) (once item2) rest) - (to-show item1 item2 `(,_ . ,rest)) + (to-show item1 item2 `(,__ . ,rest)) (on-right item1 item2 rest)))) (define zebra (relation (head-let h) (if-only (all! - (== h `((norwegian ,_ ,_ ,_ ,_) ,_ (,_ ,_ milk ,_ ,_) ,_ ,_)) - (memb `(englishman ,_ ,_ ,_ red) h) - (on-right `(,_ ,_ ,_ ,_ ivory) `(,_ ,_ ,_ ,_ green) h) - (next-to `(norwegian ,_ ,_ ,_ ,_) `(,_ ,_ ,_ ,_ blue) h) - (memb `(,_ kools ,_ ,_ yellow) h) - (memb `(spaniard ,_ ,_ dog ,_) h) - (memb `(,_ ,_ coffee ,_ green) h) - (memb `(ukrainian ,_ tea ,_ ,_) h) - (memb `(,_ luckystrikes oj ,_ ,_) h) - (memb `(japanese parliaments ,_ ,_ ,_) h) - (memb `(,_ oldgolds ,_ snails ,_) h) - (next-to `(,_ ,_ ,_ horse ,_) `(,_ kools ,_ ,_ ,_) h) - (next-to `(,_ ,_ ,_ fox ,_) `(,_ chesterfields ,_ ,_ ,_) h) + (== h `((norwegian ,__ ,__ ,__ ,__) ,__ (,__ ,__ milk ,__ ,__) ,__ ,__)) + (memb `(englishman ,__ ,__ ,__ red) h) + (on-right `(,__ ,__ ,__ ,__ ivory) `(,__ ,__ ,__ ,__ green) h) + (next-to `(norwegian ,__ ,__ ,__ ,__) `(,__ ,__ ,__ ,__ blue) h) + (memb `(,__ kools ,__ ,__ yellow) h) + (memb `(spaniard ,__ ,__ dog ,__) h) + (memb `(,__ ,__ coffee ,__ green) h) + (memb `(ukrainian ,__ tea ,__ ,__) h) + (memb `(,__ luckystrikes oj ,__ ,__) h) + (memb `(japanese parliaments ,__ ,__ ,__) h) + (memb `(,__ oldgolds ,__ snails ,__) h) + (next-to `(,__ ,__ ,__ horse ,__) `(,__ kools ,__ ,__ ,__) h) + (next-to `(,__ ,__ ,__ fox ,__) `(,__ chesterfields ,__ ,__ ,__) h) ) - (all (memb `(,_ ,_ water ,_ ,_) h) - (memb `(,_ ,_ ,_ zebra ,_) h))))) + (all (memb `(,__ ,__ water ,__ ,__) h) + (memb `(,__ ,__ ,__ zebra ,__) h))))) -'(pretty-print - (time (let loop ((n 100000)) - (cond - ((zero? n) 'done) - (else (solution (h) (zebra h)) - (loop (sub1 n))))))) +;'(_pretty-print +; (time (let loop ((n 100000)) +; (cond +; ((zero? n) 'done) +; (else (solution (h) (zebra h)) +; (loop (sub1 n))))))) (define (zebra-test) (test-check "Zebra" @@ -4443,7 +4458,8 @@ (ukrainian chesterfields tea horse blue) (englishman oldgolds milk snails red) (spaniard luckystrikes oj dog ivory) - (japanese parliaments coffee zebra green)))))) + (japanese parliaments coffee zebra green))))) +10) ; Sample timing (Pentium IV, 2GHz, 1GB RAM) ; (time (solution (h) ...)) @@ -4550,7 +4566,7 @@ ; we need to check if terms btree(T1) and btree(T2) are consistent. ; Thus, to add btree(root(T1,T2)) to our database, we need to use ; the database itself to verify btree(T1) and btree(T2). Clearly, -; we need a fixpoint. The need for the fixpoint exists no matter what is +; we need a fixpoint. The need for the fixpoint _exists no matter what is ; the representation of the database -- a finite map or a relation. ; Prolog solves the fixpoint problem by making the database global ; and using mutations (similar to the way letrec is implemented in Scheme). @@ -4884,7 +4900,9 @@ (let ((kb1 (goal-fwd kb))) (kb1 '(goal (root t1 t2))))) (cout (reify-subst '() subst) nl) #t) - #t)) + #t) + +10) ; Again, we use Y because btree and mirror-axiom-eq-2 are recursive. @@ -4921,7 +4939,7 @@ (kb `(myeq ,b ,a)))) (relation (a b) ; transitivity (to-show `(myeq ,a ,b)) - (exists (c) + (_exists (c) (all (kb `(myeq ,a ,c)) (kb `(myeq ,c ,b))))) @@ -4945,7 +4963,7 @@ (to-show `(myeq (mirror ,a) ,b)) (all (trace-vars 'mirror (a b)) - (exists (c) + (_exists (c) (all (kb `(myeq ,b (mirror ,c))) (kb `(myeq ,a ,c))))))))) @@ -5010,7 +5028,7 @@ (define-syntax un@ ; uncurry (syntax-rules () ((_ proc arg1 ...) - (lambda (arg1 ...) (@ proc arg1 ...))))) + (lambda (arg1 ...) (at@ proc arg1 ...))))) ; The initial assumptions: just the btrii ;(define init-kb (Y btrii)) @@ -5091,7 +5109,8 @@ ;(solve 1 (x) (kb `(myeq (root t1 t2) (mirror ,x)))) (solve 1 (x) (kb `(myeq ,x (mirror (root t1 t2))))) ))) -) + +10) ;; ======================================================================== ;; pure bin arith example @@ -5108,7 +5127,7 @@ ; aka: division as relation. ; The function divo below is a KANREN relation between four binary numerals ; n, m, q, and r such that the following holds -; exists r. 0<=r= 2 - (exists (r1 r2) - (all (== r `(,r1 ,r2)) - (half-adder carry-in 1 1 r1 r2)))) - - ; cin + 1 + (2*br + bb) = (2*rr + rb) where br > 0 and so is rr > 0 - (relation (carry-in bb br rb rr) - (to-show carry-in '(1) `(,bb . ,br) `(,rb . ,rr)) - (all - (pos br) (pos rr) - (exists (carry-out) - (all - (half-adder carry-in 1 bb rb carry-out) - (full-adder carry-out '() br rr))))) - - ; symmetric case for the above - (relation (head-let carry-in a '(1) r) - (all - (gt1 a) (gt1 r) - (full-adder carry-in '(1) a r))) - - ; carry-in + (2*ar + ab) + (2*br + bb) - ; = (carry-in + ab + bb) (mod 2) - ; + 2*(ar + br + (carry-in + ab + bb)/2) - ; The cases of ar= 0 or br = 0 have already been handled. - ; So, now we require ar >0 and br>0. That implies that rr>0. - (relation (carry-in ab ar bb br rb rr) - (to-show carry-in `(,ab . ,ar) `(,bb . ,br) `(,rb . ,rr)) - (all - (pos ar) (pos br) (pos rr) - (exists (carry-out) - (all - (half-adder carry-in ab bb rb carry-out) - (full-adder carry-out ar br rr)))) - ))) +; (define full-adder +; (extend-relation (carry-in a b r) +; (fact (a) 0 a '() a) ; 0 + a + 0 = a +; (relation (b) ; 0 + 0 + b = b +; (to-show 0 '() b b) +; (pos b)) +; (relation (head-let '1 a '() r) ; 1 + a + 0 = 0 + a + 1 +; (full-adder 0 a '(1) r)) +; (relation (head-let '1 '() b r) ; 1 + 0 + b = 0 + 1 + b +; (all (pos b) +; (full-adder 0 '(1) b r))) +; +; ; The following three relations are needed +; ; to make all numbers well-formed by construction, +; ; that is, to make sure the higher-order bit is one. +; (relation (head-let carry-in '(1) '(1) r) ; c + 1 + 1 >= 2 +; (_exists (r1 r2) +; (all (== r `(,r1 ,r2)) +; (half-adder carry-in 1 1 r1 r2)))) +; +; ; cin + 1 + (2*br + bb) = (2*rr + rb) where br > 0 and so is rr > 0 +; (relation (carry-in bb br rb rr) +; (to-show carry-in '(1) `(,bb . ,br) `(,rb . ,rr)) +; (all +; (pos br) (pos rr) +; (_exists (carry-out) +; (all +; (half-adder carry-in 1 bb rb carry-out) +; (full-adder carry-out '() br rr))))) +; +; ; symmetric case for the above +; (relation (head-let carry-in a '(1) r) +; (all +; (gt1 a) (gt1 r) +; (full-adder carry-in '(1) a r))) +; +; ; carry-in + (2*ar + ab) + (2*br + bb) +; ; = (carry-in + ab + bb) (mod 2) +; ; + 2*(ar + br + (carry-in + ab + bb)/2) +; ; The cases of ar= 0 or br = 0 have already been handled. +; ; So, now we require ar >0 and br>0. That implies that rr>0. +; (relation (carry-in ab ar bb br rb rr) +; (to-show carry-in `(,ab . ,ar) `(,bb . ,br) `(,rb . ,rr)) +; (all +; (pos ar) (pos br) (pos rr) +; (_exists (carry-out) +; (all +; (half-adder carry-in ab bb rb carry-out) +; (full-adder carry-out ar br rr)))) +; ))) ; After we have checked that both summands have some bits, and so we ; can decompose them the least-significant bit and the other ones, it appears @@ -5384,7 +5402,7 @@ ; uninstantiated variables. We don't know which are the input and which ; are the output. So, if we keep only the last relation for the ; case of positive summands, and try to -; (exists (x) (full-adder 0 (1 . ()) x (0 1 . ()))) +; (_exists (x) (full-adder 0 (1 . ()) x (0 1 . ()))) ; we will see x bound to (1 0) -- an invalid number. So, our adder, when ; asked to subtract numbers, gave a bad number. And it would give us ; a bad number in all the cases when we use it to subtract numbers and @@ -5433,9 +5451,63 @@ ; version would be minimal and without loss of speed. ; The following full-adder* is almost the same as full-adder above. -' -(define full-adder* - (extend-relation (carry-in a b r) +; +; (define full-adder* +; (extend-relation (carry-in a b r) +; ; (fact (a) 0 a '() a) ; 0 + a + 0 = a +; ; (relation (b) ; 0 + 0 + b = b +; ; (to-show 0 '() b b) +; ; (pos b)) +; ; (relation (head-let '1 a '() r) ; 1 + a + 0 = 0 + a + 1 +; ; (full-adder 0 a '(1) r)) +; ; (relation (head-let '1 '() b r) ; 1 + 0 + b = 0 + 1 + b +; ; (all (pos b) +; ; (full-adder 0 '(1) b r))) +; +; ; The following three relations are needed +; ; to make all numbers well-formed by construction, +; ; that is, to make sure the higher-order bit is one. +; (relation (head-let carry-in '(1) '(1) r) ; c + 1 + 1 >= 2 +; (_exists (r1 r2) +; (all (== r `(,r1 ,r2)) +; (half-adder carry-in 1 1 r1 r2)))) +; +; ; cin + 1 + (2*br + bb) = (2*rr + rb) where br > 0 and so is rr > 0 +; (relation (carry-in bb br rb rr) +; (to-show carry-in '(1) `(,bb . ,br) `(,rb . ,rr)) +; (all +; (pos br) (pos rr) +; (_exists (carry-out) +; (all +; (half-adder carry-in 1 bb rb carry-out) +; (full-adder carry-out '() br rr))))) +; +; ; symmetric case for the above +; (relation (head-let carry-in a '(1) r) +; (all +; (gt1 a) (gt1 r) +; (full-adder* carry-in '(1) a r))) +; +; ; carry-in + (2*ar + ab) + (2*br + bb) +; ; = (carry-in + ab + bb) (mod 2) +; ; + 2*(ar + br + (carry-in + ab + bb)/2) +; ; The cases of ar= 0 or br = 0 have already been handled. +; ; So, now we require ar >0 and br>0. That implies that rr>0. +; (relation (carry-in ab ar bb br rb rr) +; (to-show carry-in `(,ab . ,ar) `(,bb . ,br) `(,rb . ,rr)) +; (all +; (pos ar) (pos br) (pos rr) +; (_exists (carry-out) +; (all +; (half-adder carry-in ab bb rb carry-out) +; (full-adder* carry-out ar br rr)))) +; ))) + +; This driver handles the trivial cases and then invokes full-adder* +; coupled with the recursively enumerating generator. + +; (define full-adder +; (extend-relation (carry-in a b r) ; (fact (a) 0 a '() a) ; 0 + a + 0 = a ; (relation (b) ; 0 + 0 + b = b ; (to-show 0 '() b b) @@ -5445,73 +5517,18 @@ ; (relation (head-let '1 '() b r) ; 1 + 0 + b = 0 + 1 + b ; (all (pos b) ; (full-adder 0 '(1) b r))) - - ; The following three relations are needed - ; to make all numbers well-formed by construction, - ; that is, to make sure the higher-order bit is one. - (relation (head-let carry-in '(1) '(1) r) ; c + 1 + 1 >= 2 - (exists (r1 r2) - (all (== r `(,r1 ,r2)) - (half-adder carry-in 1 1 r1 r2)))) - - ; cin + 1 + (2*br + bb) = (2*rr + rb) where br > 0 and so is rr > 0 - (relation (carry-in bb br rb rr) - (to-show carry-in '(1) `(,bb . ,br) `(,rb . ,rr)) - (all - (pos br) (pos rr) - (exists (carry-out) - (all - (half-adder carry-in 1 bb rb carry-out) - (full-adder carry-out '() br rr))))) - - ; symmetric case for the above - (relation (head-let carry-in a '(1) r) - (all - (gt1 a) (gt1 r) - (full-adder* carry-in '(1) a r))) - - ; carry-in + (2*ar + ab) + (2*br + bb) - ; = (carry-in + ab + bb) (mod 2) - ; + 2*(ar + br + (carry-in + ab + bb)/2) - ; The cases of ar= 0 or br = 0 have already been handled. - ; So, now we require ar >0 and br>0. That implies that rr>0. - (relation (carry-in ab ar bb br rb rr) - (to-show carry-in `(,ab . ,ar) `(,bb . ,br) `(,rb . ,rr)) - (all - (pos ar) (pos br) (pos rr) - (exists (carry-out) - (all - (half-adder carry-in ab bb rb carry-out) - (full-adder* carry-out ar br rr)))) - ))) - -; This driver handles the trivial cases and then invokes full-adder* -; coupled with the recursively enumerating generator. - -' -(define full-adder - (extend-relation (carry-in a b r) - (fact (a) 0 a '() a) ; 0 + a + 0 = a - (relation (b) ; 0 + 0 + b = b - (to-show 0 '() b b) - (pos b)) - (relation (head-let '1 a '() r) ; 1 + a + 0 = 0 + a + 1 - (full-adder 0 a '(1) r)) - (relation (head-let '1 '() b r) ; 1 + 0 + b = 0 + 1 + b - (all (pos b) - (full-adder 0 '(1) b r))) - (relation (head-let carry-in a b r) - (any-interleave - ; Note that we take advantage of the fact that if - ; a + b = r and length(b) <= length(a) then length(a) <= length(r) - (all (
    = 2 - (exists (r1 r2) + (_exists (r1 r2) (all (== r `(,r1 ,r2)) (half-adder carry-in 1 1 r1 r2)))) @@ -5557,7 +5574,7 @@ (to-show carry-in '(1) `(,bb . ,br) `(,rb . ,rr)) (all (pos br) (pos rr) - (exists (carry-out) + (_exists (carry-out) (all-interleave (half-adder carry-in 1 bb rb carry-out) (full-adder carry-out '() br rr))))) @@ -5577,7 +5594,7 @@ (to-show carry-in `(,ab . ,ar) `(,bb . ,br) `(,rb . ,rr)) (all (pos ar) (pos br) (pos rr) - (exists (carry-out) + (_exists (carry-out) (all-interleave (half-adder carry-in ab bb rb carry-out) (full-adder carry-out ar br rr)))) @@ -5594,22 +5611,21 @@ (a++o y out x))) -' -(define 0 such that n + x = m - (relation (head-let n m) - (exists (x) (all (pos x) (a++o n x m))))) +;(define 0 such that n + x = m +; (relation (head-let n m) +; (_exists (x) (all (pos x) (a++o n x m))))) ; The following is an optimization: it is easier to test for the ; length of two numbers. If one number has fewer bits than the other number, ; the former is clearly shorter (provided that the numbers are well-formed, ; that is, the higher-order bit is one). So we don't need to go through ; the trouble of subtracting them. -(define 0 such that n + x = m +(define 0 such that n + x = m (relation (head-let n m) (any-interleave (
      0 (the case of m=0 is taken care of already) ; nr > 0, otherwise the number is ill-formed - (exists (nr pr) + (_exists (nr pr) (all (gt1 m) (== n `(0 . ,nr)) @@ -5632,9 +5648,9 @@ (**o nr m pr))) ; The symmetric case to the above: m is even, n is odd - (exists (mr pr) + (_exists (mr pr) (all - (== n `(1 ,_ . ,_)) ; n is odd and n > 1 + (== n `(1 ,__ . ,__)) ; n is odd and n > 1 (== m `(0 . ,mr)) (== p `(0 . ,pr)) (pos mr) (pos pr) @@ -5645,9 +5661,9 @@ ; the result is certainly greater than 1. ; we note that m > 0 and so 2*(nr*m) < 2*(nr*m) + m ; and (floor (log2 (nr*m))) < (floor (log2 (2*(nr*m) + m))) - (exists (nr p1) + (_exists (nr p1) (all - (== m `(1 ,_ . ,_)) ; m is odd and n > 1 + (== m `(1 ,__ . ,__)) ; m is odd and n > 1 (== n `(1 . ,nr)) (pos nr) (gt1 p) (0, so q*m <= n, - (exists (p) ; definitely q*m < 2*n - (all ( (n - r) is even and (n-r)/2 = m*q -; (exists (p m1) -; (all (== m `(0 . ,m1)) -; (== m1 `(_, . ,_)) -; (**o m1 q p) -; (a--o n r `(0 . ,p)))) - +; +; (define divo +; (relation (head-let n m q r) +; (any-interleave +; (all (== r n) (== q '()) (
        0, so q*m <= n, +; (_exists (p) ; definitely q*m < 2*n +; (all ( (n - r) is even and (n-r)/2 = m*q +; ; (_exists (p m1) +; ; (all (== m `(0 . ,m1)) +; ; (== m1 `(__, . ,__)) +; ; (**o m1 q p) +; ; (a--o n r `(0 . ,p)))) +; ; A faster and more refutationally complete divo algorithm ; Again, divo n m q r @@ -5745,7 +5761,7 @@ ; Note that m is L-instantiated here (0 ; in the rest, n is longer than b (all (== b '(0 1)) ; b = 2 - (exists (n1) + (_exists (n1) (all (pos n1) - (== n `(,_ ,_ . ,n1)) ; n is at least 4 + (== n `(,__ ,__ . ,n1)) ; n is at least 4 (exp2 n '() q) ; that will L-instantiate n and n1 - (split n n1 _ r)))) + (split n n1 __ r)))) ; the general case (all - (any (== b '(1 1)) (== b `(,_ ,_ ,_ . ,_))) ; b >= 3 + (any (== b '(1 1)) (== b `(,__ ,__ ,__ . ,__))) ; b >= 3 (
          symbol name) '(ctak)) diff --git a/collects/tests/mzscheme/benchmarks/common/nfa.sch b/collects/tests/mzscheme/benchmarks/common/nfa.sch index 2b3aa06d3a..b00dcd076b 100644 --- a/collects/tests/mzscheme/benchmarks/common/nfa.sch +++ b/collects/tests/mzscheme/benchmarks/common/nfa.sch @@ -42,7 +42,7 @@ 'fail)) (time (let ((input (string->list (string-append (make-string 133 #\a) "bc")))) - (let loop ((n 50000)) + (let loop ((n 150000)) (if (zero? n) 'done (begin diff --git a/collects/tests/mzscheme/benchmarks/common/nothing.sch b/collects/tests/mzscheme/benchmarks/common/nothing.sch new file mode 100644 index 0000000000..d3cd072131 --- /dev/null +++ b/collects/tests/mzscheme/benchmarks/common/nothing.sch @@ -0,0 +1 @@ +(time 1) diff --git a/collects/tests/mzscheme/benchmarks/common/nothing.ss b/collects/tests/mzscheme/benchmarks/common/nothing.ss new file mode 100644 index 0000000000..1f7a80f8fe --- /dev/null +++ b/collects/tests/mzscheme/benchmarks/common/nothing.ss @@ -0,0 +1,2 @@ + +(module nothing "wrap.ss") diff --git a/collects/tests/mzscheme/benchmarks/common/nucleic2.sch b/collects/tests/mzscheme/benchmarks/common/nucleic2.sch index 24c0b04b7b..4c3c347a87 100644 --- a/collects/tests/mzscheme/benchmarks/common/nucleic2.sch +++ b/collects/tests/mzscheme/benchmarks/common/nucleic2.sch @@ -49,10 +49,6 @@ (define-syntax FUTURE (syntax-rules () ((FUTURE x) x))) (define-syntax TOUCH (syntax-rules () ((TOUCH x) x))) -(define-syntax def-macro (syntax-rules () ((def-macro stuff ...) #t))) -(define-syntax def-struct (syntax-rules () ((def-macro stuff ...) #t))) -(define-syntax def-nuc (syntax-rules () ((def-nuc stuff ...) #t))) - (define-syntax define-structure (syntax-rules () ((define-structure #f @@ -320,204 +316,6 @@ ) -; -- SYSTEM DEPENDENT CODE ---------------------------------------------------- - -; The code in this section is not portable. It must be adapted to -; the Scheme system you are using. - -; ********** GAMBIT 2.2 - -'; Add a single-quote at the start of this line if you are NOT using Gambit -(begin - -(declare ; Compiler declarations for fast code: - (multilisp) ; - Enable the FUTURE special-form - (block) ; - Assume this file contains the entire program - (standard-bindings) ; - Assume standard bindings (this permits open-coding) - (extended-bindings) ; - Same for extensions (such as "##flonum.+") - (fixnum) ; - Use fixnum arithmetic by default - (not safe) ; - Remove all runtime type checks -) - -(define-macro (def-macro form . body) - `(DEFINE-MACRO ,form (LET () ,@body))) - -(def-macro (FLOAT+ x . l) `(,(string->symbol "##flonum.+") ,x ,@l)) -(def-macro (FLOAT- x . l) `(,(string->symbol "##flonum.-") ,x ,@l)) -(def-macro (FLOAT* x . l) `(,(string->symbol "##flonum.*") ,x ,@l)) -(def-macro (FLOAT/ x . l) `(,(string->symbol "##flonum./") ,x ,@l)) -(def-macro (FLOAT= x y) `(,(string->symbol "##flonum.=") ,x ,y)) -(def-macro (FLOAT< x y) `(,(string->symbol "##flonum.<") ,x ,y)) -(def-macro (FLOAT<= x y) `(not (,(string->symbol "##flonum.<") ,y ,x))) -(def-macro (FLOAT> x y) `(,(string->symbol "##flonum.<") ,y ,x)) -(def-macro (FLOAT>= x y) `(not (,(string->symbol "##flonum.<") ,x ,y))) -(def-macro (FLOATsin x) `(,(string->symbol "##flonum.sin") ,x)) -(def-macro (FLOATcos x) `(,(string->symbol "##flonum.cos") ,x)) -(def-macro (FLOATatan x) `(,(string->symbol "##flonum.atan") ,x)) -(def-macro (FLOATsqrt x) `(,(string->symbol "##flonum.sqrt") ,x)) -) - -; ********** MIT-SCHEME - -'; Remove the single-quote from this line if you are using MIT-Scheme -(begin - -(declare (usual-integrations)) - -(define-macro (def-macro form . body) - `(DEFINE-MACRO ,form (LET () ,@body))) - -(def-macro (nary-function op1 op2 args) - (if (null? (cdr args)) - `(,op1 ,@args) - (let loop ((args args)) - (if (null? (cdr args)) - (car args) - (loop (cons (list op2 (car args) (cadr args)) (cddr args))))))) - -(def-macro (FLOAT+ x . l) `(nary-function begin flo:+ ,(cons x l))) -(def-macro (FLOAT- x . l) `(nary-function flo:negate flo:- ,(cons x l))) -(def-macro (FLOAT* x . l) `(nary-function begin flo:* ,(cons x l))) -(def-macro (FLOAT/ x . l) `(nary-function error flo:/ ,(cons x l))) -(def-macro (FLOAT= x y) `(flo:= ,x ,y)) -(def-macro (FLOAT< x y) `(flo:< ,x ,y)) -(def-macro (FLOAT<= x y) `(not (flo:< ,y ,x))) -(def-macro (FLOAT> x y) `(flo:< ,y ,x)) -(def-macro (FLOAT>= x y) `(not (flo:< ,x ,y))) -(def-macro (FLOATsin x) `(flo:sin ,x)) -(def-macro (FLOATcos x) `(flo:cos ,x)) -(def-macro (FLOATatan x) `(flo:atan ,x)) -(def-macro (FLOATsqrt x) `(flo:sqrt ,x)) - -(def-macro (FUTURE x) x) -(def-macro (TOUCH x) x) -) - -; ********** SCM - -'; Remove the single-quote from this line if you are using SCM -(begin - -(defmacro def-macro (form . body) - `(DEFMACRO ,(car form) ,(cdr form) (LET () ,@body))) - -(def-macro (FLOAT+ x . l) `(+ ,x ,@l)) -(def-macro (FLOAT- x . l) `(- ,x ,@l)) -(def-macro (FLOAT* x . l) `(* ,x ,@l)) -(def-macro (FLOAT/ x . l) `(/ ,x ,@l)) -(def-macro (FLOAT= x y) `(= ,x ,y)) -(def-macro (FLOAT< x y) `(< ,x ,y)) -(def-macro (FLOAT<= x y) `(not (< ,y ,x))) -(def-macro (FLOAT> x y) `(< ,y ,x)) -(def-macro (FLOAT>= x y) `(not (< ,x ,y))) -(def-macro (FLOATsin x) `(sin ,x)) -(def-macro (FLOATcos x) `(cos ,x)) -(def-macro (FLOATatan x) `(atan ,x)) -(def-macro (FLOATsqrt x) `(sqrt ,x)) - -(def-macro (FUTURE x) x) -(def-macro (TOUCH x) x) -) - -; -- STRUCTURE DEFINITION MACRO ----------------------------------------------- - -; The macro "def-struct" provides a simple mechanism to define record -; structures out of vectors. The first argument to "def-struct" is a boolean -; indicating whether the vector should be tagged (to allow the type of the -; structure to be tested). The second argument is the name of the structure. -; The remaining arguments are the names of the structure's fields. A call -; to "def-struct" defines macros to -; -; 1) construct a record object of this type -; 2) fetch and store each field -; 3) test a record to see if it is of this type (only if tags are used) -; 4) define subclasses of this record with additional fields -; -; The call "(def-struct #t foo a b c)" will define the following macros: -; -; (make-foo x y) -- make a record -; (make-constant-foo x y) -- make a record (args must be constants) -; (foo? x) -- test a record -; (foo-a x) -- get field "a" -; (foo-b x) -- get field "b" -; (foo-a-set! x y) -- mutate field "a" -; (foo-b-set! x y) -- mutate field "b" -; (def-foo tag? name fields...) -- define subclass of "foo" - -(def-macro (def-struct tag? name . fields) - `(DEF-SUBSTRUCT () () 0 ,tag? ,name ,@fields)) - -(def-macro (def-substruct sup-fields sup-tags sup-length tag? name . fields) - - (define (err) - (error "Ill-formed `def-substruct'") #f) - - (define (sym . strings) - (string->symbol (apply string-append strings))) - - (if (symbol? name) - (let* ((name-str (symbol->string name)) - (tag (sym "." name-str ".")) - (all-tags (append sup-tags - (if tag? - (list (cons tag sup-length)) - '())))) - (let loop ((l1 fields) - (l2 '()) - (l3 '()) - (i (+ sup-length (if tag? 1 0)))) - (if (pair? l1) - (let ((rest (cdr l1)) (field (car l1))) - (if (symbol? field) - (let* ((field-str (symbol->string field)) - (field-ref (sym name-str "-" field-str)) - (field-set! (sym name-str "-" field-str "-set!"))) - (loop rest - (cons `(DEF-MACRO (,field-set! X Y) - `(VECTOR-SET! ,X ,,i ,Y)) - (cons `(DEF-MACRO (,field-ref X) - `(VECTOR-REF ,X ,,i)) - l2)) - (cons (cons field i) l3) - (+ i 1))) - (err))) - (let ((all-fields (append sup-fields (reverse l3)))) - `(BEGIN - ,@l2 - (DEFINE ,(sym "fields-of-" name-str) - ',all-fields) - (DEF-MACRO (,(sym "def-" name-str) TAG? NAME . FIELDS) - `(DEF-SUBSTRUCT ,',all-fields ,',all-tags ,',i - ,TAG? ,NAME ,@FIELDS)) - (DEF-MACRO (,(sym "make-constant-" name-str) . REST) - (DEFINE (ADD-TAGS I TAGS LST) - (COND ((NULL? TAGS) - LST) - ((= I (CDAR TAGS)) - (CONS (CAAR TAGS) - (ADD-TAGS (+ I 1) (CDR TAGS) LST))) - (ELSE - (CONS (CAR LST) - (ADD-TAGS (+ I 1) TAGS (CDR LST)))))) - `'#(,@(ADD-TAGS 0 ',all-tags REST))) - (DEF-MACRO (,(sym "make-" name-str) . REST) - (DEFINE (ADD-TAGS I TAGS LST) - (COND ((NULL? TAGS) - LST) - ((= I (CDAR TAGS)) - (CONS `',(CAAR TAGS) - (ADD-TAGS (+ I 1) (CDR TAGS) LST))) - (ELSE - (CONS (CAR LST) - (ADD-TAGS (+ I 1) TAGS (CDR LST)))))) - `(VECTOR ,@(ADD-TAGS 0 ',all-tags REST))) - ,@(if tag? - `((DEF-MACRO (,(sym name-str "?") X) - `(EQ? (VECTOR-REF ,X ,,sup-length) ',',tag))) - '()) - ',name))))) - (err))) - ; -- MATH UTILITIES ----------------------------------------------------------- (define constant-pi 3.14159265358979323846) @@ -539,8 +337,6 @@ ; -- POINTS ------------------------------------------------------------------- -(def-struct #f pt x y z) - (define (pt-sub p1 p2) (make-pt (FLOAT- (pt-x p1) (pt-x p2)) (FLOAT- (pt-y p1) (pt-y p2)) @@ -579,8 +375,6 @@ ; ; The components tx, ty, and tz are the translation vector. -(def-struct #f tfo a b c d e f g h i tx ty tz) - (define tfo-id ; the identity transformation matrix '#(1.0 0.0 0.0 0.0 1.0 0.0 @@ -742,21 +536,8 @@ ; Define part common to all 4 nucleotide types. -(def-struct #f nuc - dgf-base-tfo ; defines the standard position for wc and wc-dumas - P-O3*-275-tfo ; defines the standard position for the connect function - P-O3*-180-tfo - P-O3*-60-tfo - P O1P O2P O5* C5* H5* H5** C4* H4* O4* C1* H1* C2* H2** O2* H2* C3* - H3* O3* N1 N3 C2 C4 C5 C6) - ; Define remaining atoms for each nucleotide type. -(def-nuc #t rA N6 N7 N9 C8 H2 H61 H62 H8) -(def-nuc #t rC N4 O2 H41 H42 H5 H6) -(def-nuc #t rG N2 N7 N9 C8 O6 H1 H21 H22 H8) -(def-nuc #t rU O2 O4 H3 H5 H6) - ; Database of nucleotide conformations: (define rA @@ -3167,38 +2948,6 @@ ; -- PARTIAL INSTANTIATIONS --------------------------------------------------- -(def-struct #f var id tfo nuc) - -; Add a single-quote at the start of this line if you want lazy computation -(begin - -(def-macro (mk-var i tfo nuc) - `(make-var ,i ,tfo ,nuc)) - -(def-macro (absolute-pos var p) - `(tfo-apply (var-tfo ,var) ,p)) - -(def-macro (lazy-computation-of expr) - expr) -) - -'; Remove the single-quote from this line if you want lazy computation -(begin - -(def-macro (mk-var i tfo nuc) - `(make-var ,i ,tfo (make-relative-nuc ,tfo ,nuc))) - -(def-macro (absolute-pos var p) - `(force ,p)) - -(def-macro (lazy-computation-of expr) - `(delay ,expr)) -) - -(def-macro (atom-pos atom var) - `(let ((v ,var)) - (absolute-pos v (,atom (var-nuc v))))) - (define (get-var id lst) (let ((v (car lst))) (if (= id (var-id v)) @@ -3756,4 +3505,4 @@ ; To run program, evaluate: (run) -(time (let loop ([i 10]) (if (zero? i) 'done (begin (run) (loop (- i 1)))))) +(time (let loop ((i 10)) (if (zero? i) 'done (begin (run) (loop (- i 1)))))) diff --git a/collects/tests/mzscheme/benchmarks/common/petite-prelude.sch b/collects/tests/mzscheme/benchmarks/common/petite-prelude.sch new file mode 100644 index 0000000000..27dc6d694b --- /dev/null +++ b/collects/tests/mzscheme/benchmarks/common/petite-prelude.sch @@ -0,0 +1,4 @@ + +(define bitwise-and logand) +(define bitwise-ior logior) +(define bitwise-not lognot) \ No newline at end of file diff --git a/collects/tests/mzscheme/benchmarks/common/peval.sch b/collects/tests/mzscheme/benchmarks/common/peval.sch index dfa6ce3791..40d5047170 100644 --- a/collects/tests/mzscheme/benchmarks/common/peval.sch +++ b/collects/tests/mzscheme/benchmarks/common/peval.sch @@ -627,7 +627,7 @@ (let ((input (with-input-from-file "input.txt" read))) (time - (let loop ((n 20) (v 0)) + (let loop ((n 60) (v 0)) (if (zero? n) v (loop (- n 1) (test (if input 0 17))))))) diff --git a/collects/tests/mzscheme/benchmarks/common/psyntax-input.txt b/collects/tests/mzscheme/benchmarks/common/psyntax-input.txt index 4c1e8e1c31..e9bce21e27 100644 --- a/collects/tests/mzscheme/benchmarks/common/psyntax-input.txt +++ b/collects/tests/mzscheme/benchmarks/common/psyntax-input.txt @@ -213,11 +213,11 @@ ;;; The following nonstandard procedures must be provided by the ;;; implementation for this code to run. ;;; -;;; (void) +;;; (voide) ;;; returns the implementation's cannonical "unspecified value". The ;;; following usually works: ;;; -;;; (define void (lambda () (if #f #f))). +;;; (define voide (lambda () (if #f #f))). ;;; ;;; (andmap proc list1 list2 ...) ;;; returns true if proc returns true when applied to each element of list1 @@ -729,7 +729,7 @@ (if (null? (cdr exps)) (car exps) ; weed out leading void calls, assuming ordinary list representation - (if (equal? (car exps) '(void)) + (if (equal? (car exps) '(voide)) (loop (cdr exps)) `(begin ,@exps)))))) @@ -1804,7 +1804,7 @@ (if meta? (let ((x (chi-expr type value e r r w ae #t))) (top-level-eval-hook x) - (ct-eval/residualize3 ctem void (lambda () x))) + (ct-eval/residualize3 ctem voide (lambda () x))) (rt-eval/residualize rtem (lambda () (chi-expr type value e r r w ae #f))))))))) @@ -2146,7 +2146,7 @@ (define-top-level-value-hook sym (top-level-eval-hook exp)) (meta-residualize! (ct-eval/residualize3 ctem - void + voide (lambda () (build-global-definition no-source sym exp)))) (parse (cdr body) r mr (cons id ids) @@ -2266,7 +2266,7 @@ ; expand and eval meta inits for effect only (let ((x (chi-meta-frob (car body) mr))) (top-level-eval-hook x) - (meta-residualize! (ct-eval/residualize3 ctem void (lambda () x)))) + (meta-residualize! (ct-eval/residualize3 ctem voide (lambda () x)))) (f (cdr body))))))))))))) (define vmap @@ -2770,7 +2770,7 @@ empty-wrap)) ((_ name) (id? (syntax name)) - (values (wrap (syntax name) w) (syntax (void)) empty-wrap)) + (values (wrap (syntax name) w) (syntax (voide)) empty-wrap)) (_ (syntax-error (source-wrap e w ae)))))) (define parse-define-syntax @@ -2878,7 +2878,7 @@ (define chi-void (lambda () - (build-application no-source (build-primref no-source 'void) '()))) + (build-application no-source (build-primref no-source 'voide) '()))) (define ellipsis? (lambda (x) @@ -2920,7 +2920,7 @@ ((vector? x) (let ((old (vector->list x))) (let ((new (map f old))) - (if (andmap eq? old new) x (list->vector new))))) + (if (andmap2 eq? old new) x (list->vector new))))) (else x)))))) (define strip @@ -3698,13 +3698,13 @@ (let f ((ls orig-ls)) (syntax-case ls () (() '()) - ((x . r) (cons #'x (f #'r))) + ((x . r) (cons (syntax x) (f (syntax r)))) (_ (error 'syntax->list "invalid argument ~s" orig-ls)))))) (set! syntax->vector (lambda (v) (syntax-case v () - (#(x ...) (apply vector (syntax->list #'(x ...)))) + (#(x ...) (apply vector (syntax->list (syntax (x ...))))) (_ (error 'syntax->vector "invalid argument ~s" v))))) (set! syntax-object->datum @@ -4029,67 +4029,67 @@ (syntax-case p (unquote quasiquote) ((unquote p) (if (= lev 0) - #'("value" p) - (quasicons #'("quote" unquote) (quasi #'(p) (- lev 1))))) - ((quasiquote p) (quasicons #'("quote" quasiquote) (quasi #'(p) (+ lev 1)))) + (syntax ("value" p)) + (quasicons (syntax ("quote" unquote)) (quasi (syntax (p)) (- lev 1))))) + ((quasiquote p) (quasicons (syntax ("quote" quasiquote)) (quasi (syntax (p)) (+ lev 1)))) ((p . q) - (syntax-case #'p (unquote unquote-splicing) + (syntax-case (syntax p) (unquote unquote-splicing) ((unquote p ...) (if (= lev 0) - (quasilist* #'(("value" p) ...) (quasi #'q lev)) + (quasilist* (syntax (("value" p) ...)) (quasi (syntax q) lev)) (quasicons - (quasicons #'("quote" unquote) (quasi #'(p ...) (- lev 1))) - (quasi #'q lev)))) + (quasicons (syntax ("quote" unquote)) (quasi (syntax (p ...)) (- lev 1))) + (quasi (syntax q) lev)))) ((unquote-splicing p ...) (if (= lev 0) - (quasiappend #'(("value" p) ...) (quasi #'q lev)) + (quasiappend (syntax (("value" p) ...)) (quasi (syntax q) lev)) (quasicons - (quasicons #'("quote" unquote-splicing) (quasi #'(p ...) (- lev 1))) - (quasi #'q lev)))) - (_ (quasicons (quasi #'p lev) (quasi #'q lev))))) - (#(x ...) (quasivector (vquasi #'(x ...) lev))) - (p #'("quote" p)))) + (quasicons (syntax ("quote" unquote-splicing)) (quasi (syntax (p ...)) (- lev 1))) + (quasi (syntax q) lev)))) + (_ (quasicons (quasi (syntax p) lev) (quasi (syntax q) lev))))) + (#(x ...) (quasivector (vquasi (syntax (x ...)) lev))) + (p (syntax ("quote" p))))) (define (vquasi p lev) (syntax-case p () ((p . q) - (syntax-case #'p (unquote unquote-splicing) + (syntax-case (syntax p) (unquote unquote-splicing) ((unquote p ...) (if (= lev 0) - (quasilist* #'(("value" p) ...) (vquasi #'q lev)) + (quasilist* (syntax (("value" p) ...)) (vquasi (syntax q) lev)) (quasicons - (quasicons #'("quote" unquote) (quasi #'(p ...) (- lev 1))) - (vquasi #'q lev)))) + (quasicons (syntax ("quote" unquote)) (quasi (syntax (p ...)) (- lev 1))) + (vquasi (syntax q) lev)))) ((unquote-splicing p ...) (if (= lev 0) - (quasiappend #'(("value" p) ...) (vquasi #'q lev)) + (quasiappend (syntax (("value" p) ...)) (vquasi (syntax q) lev)) (quasicons (quasicons - #'("quote" unquote-splicing) - (quasi #'(p ...) (- lev 1))) - (vquasi #'q lev)))) - (_ (quasicons (quasi #'p lev) (vquasi #'q lev))))) - (() #'("quote" ())))) + (syntax ("quote" unquote-splicing)) + (quasi (syntax (p ...)) (- lev 1))) + (vquasi (syntax q) lev)))) + (_ (quasicons (quasi (syntax p) lev) (vquasi (syntax q) lev))))) + (() (syntax ("quote" ()))))) (define (quasicons x y) (with-syntax ((x x) (y y)) - (syntax-case #'y () + (syntax-case (syntax y) () (("quote" dy) - (syntax-case #'x () - (("quote" dx) #'("quote" (dx . dy))) - (_ (if (null? #'dy) #'("list" x) #'("list*" x y))))) - (("list" . stuff) #'("list" x . stuff)) - (("list*" . stuff) #'("list*" x . stuff)) - (_ #'("list*" x y))))) + (syntax-case (syntax x) () + (("quote" dx) (syntax ("quote" (dx . dy)))) + (_ (if (null? (syntax dy)) (syntax ("list" x)) (syntax ("list*" x y)))))) + (("list" . stuff) (syntax ("list" x . stuff))) + (("list*" . stuff) (syntax ("list*" x . stuff))) + (_ (syntax ("list*" x y)))))) (define (quasiappend x y) (syntax-case y () (("quote" ()) (cond - ((null? x) #'("quote" ())) + ((null? x) (syntax ("quote" ()))) ((null? (cdr x)) (car x)) - (else (with-syntax (((p ...) x)) #'("append" p ...))))) + (else (with-syntax (((p ...) x)) (syntax ("append" p ...)))))) (_ (cond ((null? x) y) - (else (with-syntax (((p ...) x) (y y)) #'("append" p ... y))))))) + (else (with-syntax (((p ...) x) (y y)) (syntax ("append" p ... y)))))))) (define (quasilist* x y) (let f ((x x)) (if (null? x) @@ -4097,35 +4097,35 @@ (quasicons (car x) (f (cdr x)))))) (define (quasivector x) (syntax-case x () - (("quote" (x ...)) #'("quote" #(x ...))) + (("quote" (x ...)) (syntax ("quote" #(x ...)))) (_ - (let f ((y x) (k (lambda (ls) #`("vector" #,@ls)))) + (let f ((y x) (k (lambda (ls) (quasisyntax ("vector" (unsyntax-splicing ls)))))) (syntax-case y () - (("quote" (y ...)) (k #'(("quote" y) ...))) - (("list" y ...) (k #'(y ...))) - (("list*" y ... z) (f #'z (lambda (ls) (k (append #'(y ...) ls))))) - (else #`("list->vector" #,x))))))) + (("quote" (y ...)) (k (syntax (("quote" y) ...)))) + (("list" y ...) (k (syntax (y ...)))) + (("list*" y ... z) (f (syntax z) (lambda (ls) (k (append (syntax (y ...)) ls))))) + (else (quasisyntax ("list->vector" (unsyntax-splicing x))))))))) (define (emit x) (syntax-case x () - (("quote" x) #''x) - (("list" x ...) #`(list #,@(map emit #'(x ...)))) + (("quote" x) (syntax 'x)) + (("list" x ...) (quasisyntax (list (unsyntax-splicing (map emit (syntax (x ...))))))) ; could emit list* for 3+ arguments if implementation supports list* (("list*" x ... y) - (let f ((x* #'(x ...))) + (let f ((x* (syntax (x ...)))) (if (null? x*) - (emit #'y) - #`(cons #,(emit (car x*)) #,(f (cdr x*)))))) - (("append" x ...) #`(append #,@(map emit #'(x ...)))) - (("vector" x ...) #`(vector #,@(map emit #'(x ...)))) - (("list->vector" x) #`(list->vector #,(emit #'x))) - (("value" x) #'x))) + (emit (syntax y)) + (quasisyntax (cons (unsyntax (emit (car x*))) (unsyntax (f (cdr x*)))))))) + (("append" x ...) (quasisyntax (append (unsyntax-splicing (map emit (syntax (x ...))))))) + (("vector" x ...) (quasisyntax (vector (unsyntax-splicing (map emit (syntax (x ...))))))) + (("list->vector" x) (quasisyntax (list->vector (unsyntax (emit (syntax x)))))) + (("value" x) (syntax x)))) (lambda (x) (syntax-case x () ; convert to intermediate language, combining introduced (but not ; unquoted source) quote expressions where possible and choosing ; optimal construction code otherwise, then emit Scheme code ; corresponding to the intermediate language forms. - ((_ e) (emit (quasi #'e 0))))))) + ((_ e) (emit (quasi (syntax e) 0))))))) (define-syntax unquote (lambda (x) @@ -4140,68 +4140,68 @@ (define (qs q n b* k) (syntax-case q (quasisyntax unsyntax unsyntax-splicing) ((quasisyntax . d) - (qs #'d (+ n 1) b* + (qs (syntax d) (+ n 1) b* (lambda (b* dnew) (k b* - (if (eq? dnew #'d) + (if (eq? dnew (syntax d)) q - (with-syntax ((d dnew)) #'(quasisyntax . d))))))) + (with-syntax ((d dnew)) (syntax (quasisyntax . d)))))))) ((unsyntax . d) (not (= n 0)) - (qs #'d (- n 1) b* + (qs (syntax d) (- n 1) b* (lambda (b* dnew) (k b* - (if (eq? dnew #'d) + (if (eq? dnew (syntax d)) q - (with-syntax ((d dnew)) #'(unsyntax . d))))))) + (with-syntax ((d dnew)) (syntax (unsyntax . d)))))))) ((unsyntax-splicing . d) (not (= n 0)) - (qs #'d (- n 1) b* + (qs (syntax d) (- n 1) b* (lambda (b* dnew) (k b* - (if (eq? dnew #'d) + (if (eq? dnew (syntax d)) q - (with-syntax ((d dnew)) #'(unsyntax-splicing . d))))))) + (with-syntax ((d dnew)) (syntax (unsyntax-splicing . d)))))))) ((unsyntax q) (= n 0) - (with-syntax (((t) (generate-temporaries #'(q)))) - (k (cons #'(t q) b*) #'t))) + (with-syntax (((t) (generate-temporaries (syntax (q))))) + (k (cons (syntax (t q)) b*) (syntax t)))) (((unsyntax q ...) . d) (= n 0) - (qs #'d n b* + (qs (syntax d) n b* (lambda (b* dnew) - (with-syntax (((t ...) (generate-temporaries #'(q ...)))) - (k (append #'((t q) ...) b*) - (with-syntax ((d dnew)) #'(t ... . d))))))) + (with-syntax (((t ...) (generate-temporaries (syntax (q ...))))) + (k (append (syntax ((t q) ...)) b*) + (with-syntax ((d dnew)) (syntax (t ... . d)))))))) (((unsyntax-splicing q ...) . d) (= n 0) - (qs #'d n b* + (qs (syntax d) n b* (lambda (b* dnew) - (with-syntax (((t ...) (generate-temporaries #'(q ...)))) - (k (append #'(((t (... ...)) q) ...) b*) - (with-syntax ((((m ...) ...) #'((t (... ...)) ...))) - (with-syntax ((d dnew)) #'(m ... ... . d)))))))) + (with-syntax (((t ...) (generate-temporaries (syntax (q ...))))) + (k (append (syntax (((t (... ...)) q) ...)) b*) + (with-syntax ((((m ...) ...) (syntax ((t (... ...)) ...)))) + (with-syntax ((d dnew)) (syntax (m ... ... . d))))))))) ((a . d) - (qs #'a n b* + (qs (syntax a) n b* (lambda (b* anew) - (qs #'d n b* + (qs (syntax d) n b* (lambda (b* dnew) (k b* - (if (and (eq? anew #'a) (eq? dnew #'d)) + (if (and (eq? anew (syntax a)) (eq? dnew (syntax d))) q - (with-syntax ((a anew) (d dnew)) #'(a . d))))))))) + (with-syntax ((a anew) (d dnew)) (syntax (a . d)))))))))) (#(x ...) - (vqs #'(x ...) n b* + (vqs (syntax (x ...)) n b* (lambda (b* xnew*) (k b* - (if (let same? ((x* #'(x ...)) (xnew* xnew*)) + (if (let same? ((x* (syntax (x ...))) (xnew* xnew*)) (if (null? x*) (null? xnew*) (and (not (null? xnew*)) (eq? (car x*) (car xnew*)) (same? (cdr x*) (cdr xnew*))))) q - (with-syntax (((x ...) xnew*)) #'#(x ...))))))) + (with-syntax (((x ...) xnew*)) (syntax #(x ...)))))))) (_ (k b* q)))) (define (vqs x* n b* k) (if (null? x*) @@ -4211,26 +4211,26 @@ (syntax-case (car x*) (unsyntax unsyntax-splicing) ((unsyntax q ...) (= n 0) - (with-syntax (((t ...) (generate-temporaries #'(q ...)))) - (k (append #'((t q) ...) b*) - (append #'(t ...) xnew*)))) + (with-syntax (((t ...) (generate-temporaries (syntax (q ...))))) + (k (append (syntax ((t q) ...)) b*) + (append (syntax (t ...)) xnew*)))) ((unsyntax-splicing q ...) (= n 0) - (with-syntax (((t ...) (generate-temporaries #'(q ...)))) - (k (append #'(((t (... ...)) q) ...) b*) - (with-syntax ((((m ...) ...) #'((t (... ...)) ...))) - (append #'(m ... ...) xnew*))))) + (with-syntax (((t ...) (generate-temporaries (syntax (q ...))))) + (k (append (syntax (((t (... ...)) q) ...)) b*) + (with-syntax ((((m ...) ...) (syntax ((t (... ...)) ...)))) + (append (syntax (m ... ...)) xnew*))))) (_ (qs (car x*) n b* (lambda (b* xnew) (k b* (cons xnew xnew*)))))))))) (syntax-case x () ((_ x) - (qs #'x 0 '() + (qs (syntax x) 0 '() (lambda (b* xnew) - (if (eq? xnew #'x) - #'(syntax x) + (if (eq? xnew (syntax x)) + (syntax (syntax x)) (with-syntax (((b ...) b*) (x xnew)) - #'(with-syntax (b ...) (syntax x)))))))))) + (syntax (with-syntax (b ...) (syntax x))))))))))) (define-syntax unsyntax (lambda (x) diff --git a/collects/tests/mzscheme/benchmarks/common/psyntax.sch b/collects/tests/mzscheme/benchmarks/common/psyntax.sch index 2e1fbd43b9..016f2199d0 100644 --- a/collects/tests/mzscheme/benchmarks/common/psyntax.sch +++ b/collects/tests/mzscheme/benchmarks/common/psyntax.sch @@ -1,3 +1,5 @@ +;; smashed into benchmark form by Matthew + ;;; psyntax.pp ;;; automatically generated from psyntax.ss ;;; Mon Feb 26 23:22:05 EST 2007 @@ -8,13 +10,12 @@ ;;; Mon Feb 26 23:22:05 EST 2007 ;;; see copyright notice in psyntax.ss -(define (error . args) (+ args)) -(define (void) (if #f #t)) -(define (annotation-expression e) #f) -(define (annotation-stripped e) e) +(define (voide) (if #f #t)) +(define (sc-annotation-expression e) #f) +(define (sc-annotation-stripped e) e) (define props '()) -(define (getprop s k) +(define (sc-getprop s k) (let loop ((props props)) (if (null? props) #f @@ -26,7 +27,7 @@ (cdar vals) (loop (cdr vals))))) (loop (cdr props)))))) -(define (putprop s k v) +(define (sc-putprop s k v) (set! props (let loop ((props props)) (if (null? props) @@ -42,7 +43,7 @@ (cons (car vals) (loop (cdr vals))))))) (cdr props)) (cons (car props) (loop (cdr props)))))))) -(define (remprop s k) +(define (sc-remprop s k) (set! props (let loop ((props props)) (if (null? props) @@ -59,24 +60,29 @@ (cdr props)) (cons (car props) (loop (cdr props)))))))) (define counter 0) -(define (gensym) +(define (jensym) (set! counter (+ counter 1)) (string->symbol (string-append "!$gen$!" (number->string counter)))) -(define (gensym? s) +(define (jensym? s) (and (symbol? s) (let ((s (symbol->string s))) (char=? (string-ref s 0) #\!)))) -(define (ormap proc l) +(define (sc-ormap proc l) (if (null? l) #f (or (proc (car l)) - (ormap proc (cdr l))))) -(define (andmap proc l) + (sc-ormap proc (cdr l))))) +(define (sc-andmap proc l) (if (null? l) #t (and (proc (car l)) - (andmap proc (cdr l))))) + (sc-andmap proc (cdr l))))) +(define (sc-andmap2 proc l l2) + (if (null? l) + #t + (and (proc (car l) (car l2)) + (sc-andmap2 proc (cdr l) (cdr l2))))) (define $sc-put-cte #f) (define $syntax-dispatch #f) @@ -87,14 +93,64 @@ (define datum->syntax-object #f) (define syntax->list #f) (define syntax->vector #f) -(define identifier? #f) -(define free-identifier=? #f) -(define bound-identifier=? #f) +(define sc-identifier? #f) +(define sc-free-identifier=? #f) +(define sc-bound-identifier=? #f) (define literal-identifier=? #f) -(define generate-temporaries #f) -(define environment? #f) +(define sc-generate-temporaries #f) +(define sc-environment? #f) (define sc-interaction-environment #f) -(define syntax-error #f) +(define sc-syntax-error #f) + +(define env (scheme-report-environment 5)) + +(define (sc-eval e) + ((eval `(lambda (syntax-object->datum + datum->syntax-object + syntax->list + syntax->vector + identifier? + free-identifier=? + bound-identifier=? + literal-identifier=? + generate-temporaries + environment? + syntax-error + $sc-put-cte + $syntax-dispatch + $make-environment + sc-expand + andmap + andmap2 + ormap + gensym + gensym? + eval + interaction-environment) + ,(cadr e)) + env) + syntax-object->datum + datum->syntax-object + syntax->list + syntax->vector + sc-identifier? + sc-free-identifier=? + sc-bound-identifier=? + literal-identifier=? + sc-generate-temporaries + sc-environment? + sc-syntax-error + $sc-put-cte + $syntax-dispatch + $make-environment + sc-expand + sc-andmap + sc-andmap2 + sc-ormap + jensym + jensym? + sc-eval + sc-interaction-environment)) ((lambda () (letrec ((noexpand62 '"noexpand") @@ -140,29 +196,29 @@ (put-cte-hook137 (lambda (symbol2513 val2512) ($sc-put-cte symbol2513 val2512 '*top*))) (get-global-definition-hook138 (lambda (symbol2511) - (getprop + (sc-getprop symbol2511 '*sc-expander*))) (put-global-definition-hook139 (lambda (symbol2510 x2509) (if (not x2509) - (remprop + (sc-remprop symbol2510 '*sc-expander*) - (putprop + (sc-putprop symbol2510 '*sc-expander* x2509)))) (read-only-binding?140 (lambda (symbol2508) '#f)) (get-import-binding141 (lambda (symbol2507 token2506) - (getprop symbol2507 token2506))) + (sc-getprop symbol2507 token2506))) (update-import-binding!142 (lambda (symbol2504 token2503 p2502) ((lambda (x2505) (if (not x2505) - (remprop + (sc-remprop symbol2504 token2503) - (putprop + (sc-putprop symbol2504 token2503 x2505))) @@ -226,7 +282,7 @@ (car exps2486) (if (equal? (car exps2486) - '(void)) + '(voide)) (loop2485 (cdr exps2486)) (cons @@ -289,7 +345,7 @@ var2470 x2474) sets2471))) - (gensym)) + (jensym)) (values (cons var2470 @@ -442,7 +498,7 @@ '#f)) (id-var-name434 id2442 '(()))))) (displaced-lexical-error299 (lambda (id2440) - (syntax-error + (sc-syntax-error id2440 (if (id-var-name434 id2440 @@ -481,14 +537,14 @@ b2433 (make-transformer-binding302 ((binding-value282 b2433)))) - (void)) + (voide)) b2433)) (lookup*300 x2431 r2430))))) (make-transformer-binding302 (lambda (b2428) ((lambda (t2429) (if t2429 t2429 - (syntax-error + (sc-syntax-error b2428 '"invalid transformer"))) (sanitize-binding271 b2428)))) @@ -509,7 +565,7 @@ (symbol? ((lambda (e2422) (if (annotation?132 e2422) - (annotation-expression e2422) + (sc-annotation-expression e2422) e2422)) (syntax-object-expression65 x2421))) @@ -521,11 +577,11 @@ (symbol? ((lambda (e2420) (if (annotation?132 e2420) - (annotation-expression e2420) + (sc-annotation-expression e2420) e2420)) (syntax-object-expression65 x2419))) (if (annotation?132 x2419) - (symbol? (annotation-expression x2419)) + (symbol? (sc-annotation-expression x2419)) '#f))))) (id-marks312 (lambda (id2418) (if (syntax-object?64 id2418) @@ -542,7 +598,7 @@ (values ((lambda (e2415) (if (annotation?132 e2415) - (annotation-expression + (sc-annotation-expression e2415) e2415)) (syntax-object-expression65 @@ -555,7 +611,7 @@ (values ((lambda (e2416) (if (annotation?132 e2416) - (annotation-expression + (sc-annotation-expression e2416) e2416)) x2414) @@ -703,7 +759,7 @@ (cons ((lambda (e2359) (if (annotation?132 e2359) - (annotation-expression + (sc-annotation-expression e2359) e2359)) (syntax-object-expression65 @@ -731,7 +787,7 @@ ((lambda (e2355) (if (annotation?132 e2355) - (annotation-expression + (sc-annotation-expression e2355) e2355)) (syntax-object-expression65 @@ -880,12 +936,12 @@ marks2326 old-binding2327))))) (id-marks312 id2324)) - (void))) + (voide))) ((lambda (x2329) ((lambda (e2330) (if (annotation?132 e2330) - (annotation-expression + (sc-annotation-expression e2330) e2330)) (if (syntax-object?64 @@ -901,7 +957,7 @@ ((lambda (e2332) (if (annotation?132 e2332) - (annotation-expression + (sc-annotation-expression e2332) e2332)) (if (syntax-object?64 @@ -951,7 +1007,7 @@ (cdr ids2316) (+ i2315 '1))))) - (void))))) + (voide))))) f2314) ids2309 '0) @@ -983,15 +1039,15 @@ (lambda (tosym2301 marks2300) (begin (if (not tosym2301) - (syntax-error + (sc-syntax-error id2299 '"identifier not visible for export") - (void)) + (voide)) (make-resolved-id418 ((lambda (x2302) ((lambda (e2303) (if (annotation?132 e2303) - (annotation-expression + (sc-annotation-expression e2303) e2303)) (if (syntax-object?64 x2302) @@ -1305,7 +1361,7 @@ ((lambda (e2250) (if (annotation?132 e2250) - (annotation-expression + (sc-annotation-expression e2250) e2250)) (if (syntax-object?64 @@ -1422,7 +1478,7 @@ ((lambda (e2217) (if (annotation?132 e2217) - (annotation-expression + (sc-annotation-expression e2217) e2217)) (syntax-object-expression65 @@ -1435,7 +1491,7 @@ ((lambda (e2218) (if (annotation?132 e2218) - (annotation-expression + (sc-annotation-expression e2218) e2218)) id2209) @@ -1481,7 +1537,7 @@ (if (eq? ((lambda (x2194) ((lambda (e2195) (if (annotation?132 e2195) - (annotation-expression + (sc-annotation-expression e2195) e2195)) (if (syntax-object?64 x2194) @@ -1492,7 +1548,7 @@ ((lambda (x2192) ((lambda (e2193) (if (annotation?132 e2193) - (annotation-expression + (sc-annotation-expression e2193) e2193)) (if (syntax-object?64 x2192) @@ -1507,7 +1563,7 @@ (if (eq? ((lambda (x2183) ((lambda (e2184) (if (annotation?132 e2184) - (annotation-expression + (sc-annotation-expression e2184) e2184)) (if (syntax-object?64 x2183) @@ -1518,7 +1574,7 @@ ((lambda (x2181) ((lambda (e2182) (if (annotation?132 e2182) - (annotation-expression + (sc-annotation-expression e2182) e2182)) (if (syntax-object?64 x2181) @@ -1559,7 +1615,7 @@ ((lambda (x2173) ((lambda (e2174) (if (annotation?132 e2174) - (annotation-expression e2174) + (sc-annotation-expression e2174) e2174)) (if (syntax-object?64 x2173) (syntax-object-expression65 x2173) @@ -1569,7 +1625,7 @@ ((lambda (x2171) ((lambda (e2172) (if (annotation?132 e2172) - (annotation-expression e2172) + (sc-annotation-expression e2172) e2172)) (if (syntax-object?64 x2171) (syntax-object-expression65 x2171) @@ -1612,14 +1668,14 @@ gooduns2159) (if (null? ids2160) - (syntax-error + (sc-syntax-error exp2156) (if (id?306 (car ids2160)) (if (bound-id-member?442 (car ids2160) gooduns2159) - (syntax-error + (sc-syntax-error (car ids2160) '"duplicate " class2155) @@ -1628,7 +1684,7 @@ (cons (car ids2160) gooduns2159))) - (syntax-error + (sc-syntax-error (car ids2160) '"invalid " class2155)))))) @@ -1665,12 +1721,12 @@ (wrap443 (if (annotation?132 ae2147) (begin - (if (not (eq? (annotation-expression + (if (not (eq? (sc-annotation-expression ae2147) x2149)) (error 'sc-expand '"internal error in source-wrap: ae/x mismatch") - (void)) + (voide)) ae2147) x2149) w2148))) @@ -1696,7 +1752,7 @@ x2146 '#(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(when-list w) #((top) (top)) #("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) ("m" top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) ("m" top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))) 'eval - (syntax-error + (sc-syntax-error (wrap443 x2146 w2144) @@ -1892,7 +1948,7 @@ '#f rib2125) (if (annotation?132 e2129) (syntax-type446 - (annotation-expression + (sc-annotation-expression e2129) r2128 w2127 e2129 rib2125) (if ((lambda (x2139) @@ -2062,16 +2118,16 @@ r2046) (displaced-lexical-error299 id2067) - (void)) + (voide)) (if (not (top-ribcage-mutable?376 top-ribcage2041)) - (syntax-error + (sc-syntax-error (source-wrap444 e2050 w2064 ae2048) '"invalid definition in read-only environment") - (void)) + (voide)) ((lambda (sym2068) (call-with-values (lambda () @@ -2088,22 +2144,22 @@ id2067 '(())) valsym2070)) - (syntax-error + (sc-syntax-error (source-wrap444 e2050 w2064 ae2048) '"definition not permitted") - (void)) + (voide)) (if (read-only-binding?140 valsym2070) - (syntax-error + (sc-syntax-error (source-wrap444 e2050 w2064 ae2048) '"invalid definition of read-only identifier") - (void)) + (voide)) (ct-eval/residualize2493 ctem2044 (lambda () @@ -2126,7 +2182,7 @@ ((lambda (e2072) (if (annotation?132 e2072) - (annotation-expression + (sc-annotation-expression e2072) e2072)) (if (syntax-object?64 @@ -2157,16 +2213,16 @@ r2046) (displaced-lexical-error299 id2076) - (void)) + (voide)) (if (not (top-ribcage-mutable?376 top-ribcage2041)) - (syntax-error + (sc-syntax-error (source-wrap444 e2050 w2073 ae2048) '"invalid definition in read-only environment") - (void)) + (voide)) ((lambda (sym2077) (call-with-values (lambda () @@ -2183,22 +2239,22 @@ id2076 '(())) valsym2079)) - (syntax-error + (sc-syntax-error (source-wrap444 e2050 w2073 ae2048) '"definition not permitted") - (void)) + (voide)) (if (read-only-binding?140 valsym2079) - (syntax-error + (sc-syntax-error (source-wrap444 e2050 w2073 ae2048) '"invalid definition of read-only identifier") - (void)) + (voide)) (if meta?2042 (ct-eval/residualize2493 ctem2044 @@ -2267,7 +2323,7 @@ ((lambda (e2082) (if (annotation?132 e2082) - (annotation-expression + (sc-annotation-expression e2082) e2082)) (if (syntax-object?64 @@ -2308,13 +2364,13 @@ (wrap443 id2086 w2049)) - (void)) + (voide)) (if (not (top-ribcage-mutable?376 top-ribcage2041)) - (syntax-error + (sc-syntax-error orig2087 '"invalid definition in read-only environment") - (void)) + (voide)) (chi-top-module482 orig2087 r2046 @@ -2347,10 +2403,10 @@ (begin (if (not (top-ribcage-mutable?376 top-ribcage2041)) - (syntax-error + (sc-syntax-error orig2090 '"invalid definition in read-only environment") - (void)) + (voide)) (ct-eval/residualize2493 ctem2044 (lambda () @@ -2371,7 +2427,7 @@ '(displaced-lexical)) (displaced-lexical-error299 mid2088) - (syntax-error + (sc-syntax-error mid2088 '"unknown module")))) (binding-type281 @@ -2399,16 +2455,16 @@ r2046) (displaced-lexical-error299 new-id2095) - (void)) + (voide)) (if (not (top-ribcage-mutable?376 top-ribcage2041)) - (syntax-error + (sc-syntax-error (source-wrap444 e2050 w2049 ae2048) '"invalid definition in read-only environment") - (void)) + (voide)) ((lambda (sym2096) (call-with-values (lambda () @@ -2425,22 +2481,22 @@ new-id2095 '(())) valsym2098)) - (syntax-error + (sc-syntax-error (source-wrap444 e2050 w2049 ae2048) '"definition not permitted") - (void)) + (voide)) (if (read-only-binding?140 valsym2098) - (syntax-error + (sc-syntax-error (source-wrap444 e2050 w2049 ae2048) '"invalid definition of read-only identifier") - (void)) + (voide)) (ct-eval/residualize2493 ctem2044 (lambda () @@ -2469,7 +2525,7 @@ ((lambda (e2100) (if (annotation?132 e2100) - (annotation-expression + (sc-annotation-expression e2100) e2100)) (if (syntax-object?64 @@ -2483,13 +2539,13 @@ w2049)))) (begin (if meta-seen?2039 - (syntax-error + (sc-syntax-error (source-wrap444 e2050 w2049 ae2048) '"invalid meta definition") - (void)) + (voide)) (if meta?2042 ((lambda (x2101) (begin @@ -2497,7 +2553,7 @@ x2101) (ct-eval/residualize3494 ctem2044 - void + voide (lambda () x2101)))) (chi-expr499 @@ -2725,16 +2781,16 @@ id1909 '(())) valsym1938)) - (syntax-error + (sc-syntax-error orig1917 '"definition not permitted") - (void)) + (voide)) (if (read-only-binding?140 valsym1938) - (syntax-error + (sc-syntax-error orig1917 '"invalid definition of read-only identifier") - (void)) + (voide)) (list '$sc-put-cte (list @@ -2759,7 +2815,7 @@ ((lambda (e1940) (if (annotation?132 e1940) - (annotation-expression + (sc-annotation-expression e1940) e1940)) (if (syntax-object?64 @@ -2918,7 +2974,7 @@ ((lambda (e1961) (if (annotation?132 e1961) - (annotation-expression + (sc-annotation-expression e1961) e1961)) (if (syntax-object?64 @@ -3002,7 +3058,7 @@ ((lambda (e1967) (if (annotation?132 e1967) - (annotation-expression + (sc-annotation-expression e1967) e1967)) (if (syntax-object?64 @@ -3060,7 +3116,7 @@ ((lambda (e1973) (if (annotation?132 e1973) - (annotation-expression + (sc-annotation-expression e1973) e1973)) (if (syntax-object?64 @@ -3084,12 +3140,12 @@ (if (not (symbol? (get-indirect-label360 label1955))) - (syntax-error + (sc-syntax-error (module-binding-id464 b1953) '"unexported target of alias") - (void)) - (void)) + (voide)) + (voide)) rest1974)) (ctdefs1924)))) (error 'sc-expand-internal @@ -3135,7 +3191,7 @@ fexports1878 ids1877) (letrec ((defined?1880 (lambda (e1887 ids1886) - (ormap + (sc-ormap (lambda (x1888) (if (import-interface?380 x1888) @@ -3149,7 +3205,7 @@ ((lambda (e1894) (if (annotation?132 e1894) - (annotation-expression + (sc-annotation-expression e1894) e1894)) (if (syntax-object?64 @@ -3179,7 +3235,7 @@ ((lambda (e1903) (if (annotation?132 e1903) - (annotation-expression + (sc-annotation-expression e1903) e1903)) (if (syntax-object?64 @@ -3196,7 +3252,7 @@ ((lambda (e1901) (if (annotation?132 e1901) - (annotation-expression + (sc-annotation-expression e1901) e1901)) (if (syntax-object?64 @@ -3233,14 +3289,14 @@ fexports1883) (if (not (null? missing1882)) - (syntax-error + (sc-syntax-error (car missing1882) (if (= (length missing1882) '1) '"missing definition for export" '"missing definition for multiple exports, including")) - (void)) + (voide)) ((lambda (e1885 fexports1884) (if (defined?1880 @@ -3400,7 +3456,7 @@ ((lambda (e1852) (if (annotation?132 e1852) - (annotation-expression + (sc-annotation-expression e1852) e1852)) (if (syntax-object?64 @@ -3420,7 +3476,7 @@ ((lambda (e1854) (if (annotation?132 e1854) - (annotation-expression + (sc-annotation-expression e1854) e1854)) (if (syntax-object?64 @@ -3442,7 +3498,7 @@ (if (not (null? cls1831)) ((lambda (cls1834) - (syntax-error + (sc-syntax-error source-exp1826 '"duplicate definition for " (symbol->string @@ -3450,7 +3506,7 @@ '" in")) (syntax-object->datum cls1831)) - (void)) + (voide)) ((letrec ((lp21835 (lambda (ls21837 cls1836) (if (null? @@ -3472,7 +3528,7 @@ (car ls1825) (cdr ls1825) '()) - (void))))) + (voide))))) (chi-external486 (lambda (ribcage1721 source-exp1720 body1719 r1718 mr1717 ctem1716 exports1715 fexports1714 @@ -3610,7 +3666,7 @@ (meta-residualize!1713 (ct-eval/residualize3494 ctem1716 - void + voide (lambda () (list 'define @@ -3652,7 +3708,7 @@ ((lambda (e1753) (if (annotation?132 e1753) - (annotation-expression + (sc-annotation-expression e1753) e1753)) (if (syntax-object?64 @@ -3881,7 +3937,7 @@ (extend-ribcage-barrier!412 ribcage1721 mid1781) - (void)) + (voide)) (do-import!507 import-iface1788 ribcage1721) @@ -3911,7 +3967,7 @@ '(displaced-lexical)) (displaced-lexical-error299 mid1781) - (syntax-error + (sc-syntax-error mid1781 '"unknown module")))) (binding-type281 @@ -4091,13 +4147,13 @@ '#f))) (begin (if meta-seen?1726 - (syntax-error + (sc-syntax-error (source-wrap444 e1738 w1737 ae1736) '"invalid meta definition") - (void)) + (voide)) ((letrec ((f1807 (lambda (body1808) (if ((lambda (t1809) (if t1809 @@ -4122,7 +4178,7 @@ (meta-residualize!1713 (ct-eval/residualize3494 ctem1716 - void + voide (lambda () x1810))))) (chi-meta-frob496 @@ -4174,7 +4230,7 @@ i1707)) (do1706 (+ i1707 '1))) - (void))))) + (voide))))) do1706) '0)) (vector-length v1703)))) @@ -4305,7 +4361,7 @@ (if (not t1677) (set! t1677 (thunk1675)) - (void)) + (voide)) (top-level-eval-hook133 t1677))) (lambda () @@ -4324,7 +4380,7 @@ (begin (if (memq 'c ctem1672) (eval-thunk1671) - (void)) + (voide)) (if (memq 'r ctem1672) (if ((lambda (t1673) (if t1673 @@ -4487,7 +4543,7 @@ (if (memv t1629 '(meta-form)) - (syntax-error + (sc-syntax-error (source-wrap444 e1626 w1623 @@ -4501,7 +4557,7 @@ e1626 w1623 ae1622) - (syntax-error + (sc-syntax-error (source-wrap444 e1626 w1623 @@ -4515,7 +4571,7 @@ e1626 w1623 ae1622) - (syntax-error + (sc-syntax-error (source-wrap444 e1626 w1623 @@ -4535,7 +4591,7 @@ id1639 exports1638 forms1637) - (syntax-error + (sc-syntax-error orig1640 '"invalid context for definition"))) (if (memv @@ -4550,7 +4606,7 @@ (lambda (orig1643 only?1642 mid1641) - (syntax-error + (sc-syntax-error orig1643 '"invalid context for definition"))) (if (memv @@ -4561,7 +4617,7 @@ e1626 w1623 ae1622) - (syntax-error + (sc-syntax-error (source-wrap444 e1626 w1623 @@ -4570,7 +4626,7 @@ (if (memv t1629 '(syntax)) - (syntax-error + (sc-syntax-error (source-wrap444 e1626 w1623 @@ -4584,7 +4640,7 @@ e1626 w1623 ae1622)) - (syntax-error + (sc-syntax-error (source-wrap444 e1626 w1623 @@ -4606,7 +4662,7 @@ e11616))) tmp1615) ((lambda (_1620) - (syntax-error + (sc-syntax-error (source-wrap444 e1612 w1609 @@ -4679,13 +4735,13 @@ (begin (if (read-only-binding?140 n1601) - (syntax-error + (sc-syntax-error (source-wrap444 e1600 w1597 ae1596) '"invalid assignment to read-only variable") - (void)) + (voide)) (list 'set! sym1605 @@ -4712,7 +4768,7 @@ (wrap443 id1588 w1597)) - (syntax-error + (sc-syntax-error (source-wrap444 e1600 w1597 @@ -4735,7 +4791,7 @@ (id-var-name434 id1588 w1579))) tmp1583) ((lambda (_1606) - (syntax-error + (sc-syntax-error (source-wrap444 e1581 w1579 @@ -4820,7 +4876,7 @@ x1569)) (if (symbol? x1569) - (syntax-error + (sc-syntax-error (source-wrap444 e1563 w1561 @@ -4836,11 +4892,11 @@ (out1566 (lambda (id1567) (begin - (if (not (identifier? id1567)) - (syntax-error + (if (not (sc-identifier? id1567)) + (sc-syntax-error id1567 '"environment argument is not an identifier") - (void)) + (voide)) (lookup301 (id-var-name434 id1567 @@ -4869,10 +4925,10 @@ inits1551) (begin (if (null? exprs1555) - (syntax-error + (sc-syntax-error outer-form1546 '"no expressions in body") - (void)) + (voide)) (build-body237 '#f (reverse vars1553) @@ -5006,7 +5062,7 @@ ((lambda (e1479) (if (annotation?132 e1479) - (annotation-expression + (sc-annotation-expression e1479) e1479)) (if (syntax-object?64 @@ -5228,7 +5284,7 @@ (extend-ribcage-barrier!412 ribcage1451 mid1508) - (void)) + (voide)) (do-import!507 import-iface1515 ribcage1451) @@ -5255,7 +5311,7 @@ '(displaced-lexical)) (displaced-lexical-error299 mid1508) - (syntax-error + (sc-syntax-error mid1508 '"unknown module")))) (binding-type281 @@ -5427,13 +5483,13 @@ '#f))) (begin (if meta-seen?1454 - (syntax-error + (sc-syntax-error (source-wrap444 e1467 w1466 ae1465) '"invalid meta definition") - (void)) + (voide)) ((letrec ((f1532 (lambda (body1533) (if ((lambda (t1534) (if t1534 @@ -5482,10 +5538,10 @@ ((lambda (label1443) (begin (if (not label1443) - (syntax-error + (sc-syntax-error id1442 '"exported identifier not visible") - (void)) + (voide)) label1443)) (id-var-name-loc433 id1442 @@ -5531,7 +5587,7 @@ (wrap443 x1436 *w1410) - (syntax-error + (sc-syntax-error (source-wrap444 e1413 w1412 @@ -5569,7 +5625,7 @@ form1422))) tmp1416) ((lambda (_1430) - (syntax-error + (sc-syntax-error (source-wrap444 e1413 w1412 @@ -5617,7 +5673,7 @@ w1392))) tmp1402) ((lambda (_1409) - (syntax-error + (sc-syntax-error (source-wrap444 e1393 w1392 @@ -5698,11 +5754,11 @@ (wrap443 name1388 w1363) - '#(syntax-object (void) ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(e w ae) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) ("m" top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) ("m" top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t))) + '#(syntax-object (voide) ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(e w ae) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) ("m" top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) ("m" top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t))) '(()))) tmp1385) ((lambda (_1390) - (syntax-error + (sc-syntax-error (source-wrap444 e1364 w1363 @@ -5778,7 +5834,7 @@ w1339)) tmp1354) ((lambda (_1361) - (syntax-error + (sc-syntax-error (source-wrap444 e1340 w1339 @@ -5802,7 +5858,7 @@ (lambda (_1336 form1335) form1335) tmp1334) ((lambda (_1337) - (syntax-error + (sc-syntax-error (source-wrap444 e1332 w1331 @@ -5824,7 +5880,7 @@ (cons e11324 e21323))) tmp1322) ((lambda (_1329) - (syntax-error + (sc-syntax-error (source-wrap444 e1320 w1319 @@ -5852,7 +5908,7 @@ (values new-id1315 old-id1314)) tmp1310) ((lambda (_1317) - (syntax-error + (sc-syntax-error (source-wrap444 e1308 w1307 @@ -5882,7 +5938,7 @@ (cons e11302 e21301)) tmp1300) ((lambda (_1305) - (syntax-error + (sc-syntax-error (source-wrap444 e1295 w1294 @@ -5904,7 +5960,7 @@ ((lambda (ids1275) (if (not (valid-bound-ids?439 ids1275)) - (syntax-error + (sc-syntax-error e1269 '"invalid parameter list in") ((lambda (labels1277 @@ -5941,7 +5997,7 @@ ((lambda (old-ids1284) (if (not (valid-bound-ids?439 old-ids1284)) - (syntax-error + (sc-syntax-error e1269 '"invalid parameter list in") ((lambda (labels1286 @@ -5983,7 +6039,7 @@ ids1283))) tmp1280) ((lambda (_1291) - (syntax-error + (sc-syntax-error e1269)) tmp1270))) ($syntax-dispatch @@ -6056,7 +6112,7 @@ id1251)) tmp1247) ((lambda (_1263) - (syntax-error + (sc-syntax-error (source-wrap444 e1244 w1241 @@ -6069,7 +6125,7 @@ . each-any)))) e1244))) - (chi-void518 (lambda () (cons 'void '()))) + (chi-void518 (lambda () (cons 'voide '()))) (ellipsis?519 (lambda (x1239) (if (nonsymbol-id?305 x1239) (literal-id=?436 @@ -6082,7 +6138,7 @@ (strip-annotation520 (car x1238)) (strip-annotation520 (cdr x1238))) (if (annotation?132 x1238) - (annotation-stripped x1238) + (sc-annotation-stripped x1238) x1238)))) (strip*521 (lambda (x1231 w1230 fn1229) (if (memq 'top (wrap-marks316 w1230)) @@ -6115,7 +6171,7 @@ (if (vector? x1233) ((lambda (old1236) ((lambda (new1237) - (if (andmap + (if (sc-andmap2 eq? old1236 new1237) @@ -6146,8 +6202,8 @@ (gen-var523 (lambda (id1223) ((lambda (id1224) (if (annotation?132 id1224) - (gensym) - (gensym))) + (jensym) + (jensym))) (if (syntax-object?64 id1223) (syntax-object-expression65 id1223) id1223)))) @@ -6186,7 +6242,7 @@ (if (annotation?132 vars1222) (lvl1219 - (annotation-expression + (sc-annotation-expression vars1222) ls1221 w1220) @@ -6258,10 +6314,10 @@ (if (not (eq? (interface-token455 iface1208) token1205)) - (syntax-error + (sc-syntax-error id1199 '"import mismatch for module") - (void)) + (voide)) (sc-put-module1200 (interface-exports454 iface1208) @@ -6272,7 +6328,7 @@ (interface-exports454 iface1208))) (binding-value282 b1206)) - (syntax-error + (sc-syntax-error id1199 '"unknown module"))) (binding-type281 b1206))) @@ -6310,7 +6366,7 @@ (if (memv t1193 '(displaced-lexical)) (displaced-lexical-error299 (wrap443 id1192 w1168)) - (void))) + (voide))) (binding-type281 (lookup301 n1191 r1170)))) var1183 @@ -6332,7 +6388,7 @@ var1183))) tmp1173) ((lambda (_1196) - (syntax-error (source-wrap444 e1171 w1168 ae1167))) + (sc-syntax-error (source-wrap444 e1171 w1168 ae1167))) tmp1172))) ($syntax-dispatch tmp1172 @@ -6350,7 +6406,7 @@ (list 'quote (strip522 e1163 w1157))) tmp1162) ((lambda (_1165) - (syntax-error (source-wrap444 e1160 w1157 ae1156))) + (sc-syntax-error (source-wrap444 e1160 w1157 ae1156))) tmp1161))) ($syntax-dispatch tmp1161 '(any any)))) e1160))) @@ -6386,7 +6442,7 @@ maps1103))) (if (ellipsis?1096 e1099) - (syntax-error + (sc-syntax-error src1100 '"misplaced ellipsis in syntax form") (values @@ -6412,7 +6468,7 @@ (lambda (dots1111 e1110) (if vec?1095 - (syntax-error + (sc-syntax-error src1100 '"misplaced ellipsis in syntax template") (gen-syntax1039 @@ -6465,7 +6521,7 @@ maps1130) (if (null? (car maps1130)) - (syntax-error + (sc-syntax-error src1100 '"extra ellipsis in syntax form") (values @@ -6521,7 +6577,7 @@ maps1138) (if (null? (car maps1138)) - (syntax-error + (sc-syntax-error src1100 '"extra ellipsis in syntax form") (values @@ -6623,7 +6679,7 @@ (if (= level1088 '0) (values var1089 maps1087) (if (null? maps1087) - (syntax-error + (sc-syntax-error src1090 '"missing ellipsis in syntax form") (call-with-values @@ -6670,7 +6726,7 @@ ((lambda (formals1078 actuals1077) (if (eq? (car e1076) 'ref) (car actuals1077) - (if (andmap + (if (sc-andmap (lambda (x1079) (if (eq? (car x1079) 'ref) @@ -6807,7 +6863,7 @@ (lambda (e1059 maps1058) (regen1046 e1059)))) tmp1055) - ((lambda (_1060) (syntax-error e1053)) + ((lambda (_1060) (sc-syntax-error e1053)) tmp1054))) ($syntax-dispatch tmp1054 '(any any)))) e1053)) @@ -6829,7 +6885,7 @@ (lambda (vars1038 body1037) (list 'lambda vars1038 body1037)))) tmp1034) - (syntax-error tmp1033))) + (sc-syntax-error tmp1033))) ($syntax-dispatch tmp1033 '(any . any)))) e1032))) (global-extend304 @@ -6877,7 +6933,7 @@ id1014)) tmp1010) ((lambda (_1026) - (syntax-error (source-wrap444 e1008 w1005 ae1004))) + (sc-syntax-error (source-wrap444 e1008 w1005 ae1004))) tmp1009))) ($syntax-dispatch tmp1009 @@ -6909,7 +6965,7 @@ (chi498 else998 r990 mr989 w988 m?986))) tmp997) ((lambda (_1002) - (syntax-error + (sc-syntax-error (source-wrap444 e991 w988 ae987))) tmp992))) ($syntax-dispatch tmp992 '(any any any any))))) @@ -7197,12 +7253,12 @@ (map car pvars906) pat899 '"pattern variable") - (if (not (andmap + (if (not (sc-andmap (lambda (x908) (not (ellipsis?519 (car x908)))) pvars906)) - (syntax-error + (sc-syntax-error pat899 '"misplaced ellipsis in syntax-case pattern") ((lambda (y909) @@ -7344,7 +7400,7 @@ exp893)) tmp892) ((lambda (_896) - (syntax-error + (sc-syntax-error (car clauses883) '"invalid syntax-case clause")) tmp886))) @@ -7363,7 +7419,7 @@ (if tmp870 (apply (lambda (_874 val873 key872 m871) - (if (andmap + (if (sc-andmap (lambda (x876) (if (id?306 x876) (not (ellipsis?519 x876)) @@ -7380,11 +7436,11 @@ (chi498 val873 r866 mr865 '(()) m?862)))) (gen-var523 'tmp)) - (syntax-error + (sc-syntax-error e868 '"invalid literals list in"))) tmp870) - (syntax-error tmp869))) + (sc-syntax-error tmp869))) ($syntax-dispatch tmp869 '(any any each-any . each-any)))) @@ -7399,15 +7455,15 @@ (if tmp853 (apply (lambda (id855 e854) - (if (identifier? + (if (sc-identifier? id855) - (andmap + (sc-andmap proper-export?828 e854) '#f)) tmp853) ((lambda (id857) - (identifier? id857)) + (sc-identifier? id857)) tmp852))) ($syntax-dispatch tmp852 @@ -7420,7 +7476,7 @@ (if tmp832 (apply (lambda (_835 e834 d833) - (if (andmap proper-export?828 e834) + (if (sc-andmap proper-export?828 e834) (list '#(syntax-object begin ((top) #(ribcage #(_ e d) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig) #((top)) #("i")) #(ribcage (proper-export?) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) ("m" top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) ("m" top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t))) (cons @@ -7435,7 +7491,7 @@ (cons orig830 '#(syntax-object (#f anon) ((top) #(ribcage #(_ e d) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(orig) #((top)) #("i")) #(ribcage (proper-export?) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) ("m" top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) ("m" top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))))) - (syntax-error + (sc-syntax-error x827 '"invalid exports list in"))) tmp832) @@ -7443,12 +7499,12 @@ (if (if tmp839 (apply (lambda (_843 m842 e841 d840) - (identifier? m842)) + (sc-identifier? m842)) tmp839) '#f) (apply (lambda (_847 m846 e845 d844) - (if (andmap proper-export?828 e845) + (if (sc-andmap proper-export?828 e845) (cons '#(syntax-object $module ((top) #(ribcage #(_ m e d) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage #(orig) #((top)) #("i")) #(ribcage (proper-export?) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) ("m" top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) ("m" top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t))) (cons @@ -7456,11 +7512,11 @@ (cons m846 (cons e845 d844)))) - (syntax-error + (sc-syntax-error x827 '"invalid exports list in"))) tmp839) - (syntax-error tmp831))) + (sc-syntax-error tmp831))) ($syntax-dispatch tmp831 '(any any each-any . each-any))))) @@ -7516,7 +7572,7 @@ '(displaced-lexical)) (displaced-lexical-error299 m819) - (syntax-error + (sc-syntax-error m819 '"unknown module")))) (binding-type281 b820))) @@ -7569,12 +7625,12 @@ np812) prefix808) '#f)) - (syntax-error + (sc-syntax-error id809 (string-append '"missing expected prefix " prefix808)) - (void)) + (voide)) (datum->syntax-object id809 (string->symbol @@ -7600,7 +7656,7 @@ ((lambda (e806) (if (annotation?132 e806) - (annotation-expression + (sc-annotation-expression e806) e806)) (if (syntax-object?64 @@ -7623,8 +7679,8 @@ (apply (lambda (m663 id662) - (andmap - identifier? + (sc-andmap + sc-identifier? id662)) tmp661) '#f) @@ -7664,7 +7720,7 @@ id665 '#f))) tmp671) - (syntax-error + (sc-syntax-error tmp670))) ($syntax-dispatch tmp670 @@ -7679,8 +7735,8 @@ (apply (lambda (m678 id677) - (andmap - identifier? + (sc-andmap + sc-identifier? id677)) tmp676) '#f) @@ -7721,7 +7777,7 @@ id688 '#f))) tmp687) - (syntax-error + (sc-syntax-error tmp685))) ($syntax-dispatch tmp685 @@ -7740,7 +7796,7 @@ (apply (lambda (m695 prefix-id694) - (identifier? + (sc-identifier? prefix-id694)) tmp693) '#f) @@ -7822,7 +7878,7 @@ id703 '#f))) tmp702) - (syntax-error + (sc-syntax-error tmp701))) ($syntax-dispatch tmp701 @@ -7835,7 +7891,7 @@ (gen-mid638 mid700) exports698 - (generate-temporaries + (sc-generate-temporaries exports698) (map (prefix-add636 prefix-id696) @@ -7846,7 +7902,7 @@ (apply (lambda (m719 prefix-id718) - (identifier? + (sc-identifier? prefix-id718)) tmp717) '#f) @@ -7928,7 +7984,7 @@ id727 '#f))) tmp726) - (syntax-error + (sc-syntax-error tmp725))) ($syntax-dispatch tmp725 @@ -7941,7 +7997,7 @@ (gen-mid638 mid724) exports722 - (generate-temporaries + (sc-generate-temporaries exports722) (map (prefix-drop637 prefix-id720) @@ -7953,11 +8009,11 @@ (lambda (m744 new-id743 old-id742) - (if (andmap - identifier? + (if (sc-andmap + sc-identifier? new-id743) - (andmap - identifier? + (sc-andmap + sc-identifier? old-id742) '#f)) tmp741) @@ -8046,7 +8102,7 @@ other-id757) '#f))) tmp756) - (syntax-error + (sc-syntax-error tmp753))) ($syntax-dispatch tmp753 @@ -8057,7 +8113,7 @@ d751 (gen-mid638 mid752) - (generate-temporaries + (sc-generate-temporaries old-id747) (difference635 exports750 @@ -8069,11 +8125,11 @@ (lambda (m776 new-id775 old-id774) - (if (andmap - identifier? + (if (sc-andmap + sc-identifier? new-id775) - (andmap - identifier? + (sc-andmap + sc-identifier? old-id774) '#f)) tmp773) @@ -8134,7 +8190,7 @@ other-id787) '#f))) tmp786) - (syntax-error + (sc-syntax-error tmp785))) ($syntax-dispatch tmp785 @@ -8150,7 +8206,7 @@ (if (if tmp797 (apply (lambda (mid798) - (identifier? + (sc-identifier? mid798)) tmp797) '#f) @@ -8173,7 +8229,7 @@ (if (if tmp800 (apply (lambda (mid801) - (identifier? + (sc-identifier? mid801)) tmp800) '#f) @@ -8193,7 +8249,7 @@ '#f))) tmp800) ((lambda (_803) - (syntax-error + (sc-syntax-error m655 '"invalid module specifier")) tmp660))) @@ -8246,7 +8302,7 @@ each-any)))) m655)) tmp657) - (syntax-error + (sc-syntax-error tmp656))) ($syntax-dispatch tmp656 @@ -8278,7 +8334,7 @@ '#(syntax-object begin ((top) #(ribcage #(d) #((top)) #("i")) #(ribcage #(_ m) #((top) (top)) #("i" "i")) #(ribcage (modspec* modspec gen-mid prefix-drop prefix-add difference) ((top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i")) #(ribcage #(r) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(orig import-only?) #((top) (top)) #("i" "i")) #(ribcage ($import-help $module-exports) ((top) (top)) ("i" "i")) #(ribcage (lambda-var-list gen-var strip strip* strip-annotation ellipsis? chi-void chi-local-syntax chi-lambda-clause parse-begin parse-alias parse-eval-when parse-meta parse-define-syntax parse-define parse-import parse-module do-import! lookup-import-label import-mark-delta chi-internal chi-body chi-macro chi-set! chi-application chi-expr chi chi-sequence chi-meta-frob chi-frobs ct-eval/residualize3 ct-eval/residualize2 rt-eval/residualize initial-mode-set update-mode-set do-top-import vfor-each vmap chi-external check-defined-ids check-module-exports id-set-diff chi-top-module set-frob-meta?! set-frob-e! frob-meta? frob-e frob? make-frob create-module-binding set-module-binding-exported! set-module-binding-val! set-module-binding-imps! set-module-binding-label! set-module-binding-id! set-module-binding-type! module-binding-exported module-binding-val module-binding-imps module-binding-label module-binding-id module-binding-type module-binding? make-module-binding make-resolved-interface make-unresolved-interface set-interface-token! set-interface-exports! set-interface-marks! interface-token interface-exports interface-marks interface? make-interface flatten-exports chi-top chi-top-sequence chi-top* syntax-type chi-when-list source-wrap wrap bound-id-member? invalid-ids-error distinct-bound-ids? valid-bound-ids? bound-id=? help-bound-id=? literal-id=? free-id=? id-var-name id-var-name-loc id-var-name&marks id-var-name-loc&marks top-id-free-var-name top-id-bound-var-name anon diff-marks same-marks? join-subst join-marks join-wraps smart-append resolved-id-var-name id->resolved-id make-resolved-id make-binding-wrap store-import-binding lookup-import-binding-name extend-ribcage-subst! extend-ribcage-barrier-help! extend-ribcage-barrier! import-extend-ribcage! extend-ribcage! make-empty-ribcage barrier-marker new-mark anti-mark the-anti-mark set-env-wrap! set-env-top-ribcage! env-wrap env-top-ribcage env? make-env set-import-interface-new-marks! set-import-interface-interface! import-interface-new-marks import-interface-interface import-interface? make-import-interface set-top-ribcage-mutable?! set-top-ribcage-key! top-ribcage-mutable? top-ribcage-key top-ribcage? make-top-ribcage set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels label? gen-label set-indirect-label! get-indirect-label indirect-label? gen-indirect-label anon only-top-marked? top-marked? tmp-wrap top-wrap empty-wrap wrap-subst wrap-marks make-wrap id-sym-name&marks id-subst id-marks id-sym-name id? nonsymbol-id? global-extend defer-or-eval-transformer make-transformer-binding lookup lookup* displaced-lexical-error displaced-lexical? extend-var-env* extend-env* extend-env null-env binding? set-binding-value! set-binding-type! binding-value binding-type make-binding sanitize-binding arg-check no-source unannotate self-evaluating? lexical-var? build-lexical-var build-top-module build-body build-letrec build-sequence build-data build-primref built-lambda? build-lambda build-revisit-only build-visit-only build-cte-install build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application generate-id update-import-binding! get-import-binding read-only-binding? put-global-definition-hook get-global-definition-hook put-cte-hook error-hook define-top-level-value-hook local-eval-hook top-level-eval-hook annotation? fx>= fx<= fx> fx< fx= fx- fx+ set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object noexpand let-values define-structure unless when) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) ("m" top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) ("m" top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t))) d648)) tmp647) - (syntax-error + (sc-syntax-error tmp645))) ($syntax-dispatch tmp645 @@ -8286,7 +8342,7 @@ (map modspec*640 m643))) tmp642) - (syntax-error tmp641))) + (sc-syntax-error tmp641))) ($syntax-dispatch tmp641 '(any . each-any)))) @@ -8318,11 +8374,11 @@ (wrap-marks316 '((top))) (cons top-ribcage623 (wrap-subst317 '((top))))))) (make-top-ribcage373 token622 mutable?621)))) - (set! environment? (lambda (x620) (env?386 x620))) + (set! sc-environment? (lambda (x620) (env?386 x620))) (set! sc-interaction-environment ((lambda (e619) (lambda () e619)) ($make-environment '*top* '#t))) - (set! identifier? (lambda (x618) (nonsymbol-id?305 x618))) + (set! sc-identifier? (lambda (x618) (nonsymbol-id?305 x618))) (set! datum->syntax-object (lambda (id616 datum615) (begin @@ -8332,7 +8388,7 @@ 'datum->syntax-object '"invalid argument" x617) - (void))) + (voide))) id616) (make-syntax-object63 datum615 @@ -8379,7 +8435,7 @@ v600))) (set! syntax-object->datum (lambda (x599) (strip522 x599 '(())))) - (set! generate-temporaries + (set! sc-generate-temporaries ((lambda (n595) (lambda (ls596) (begin @@ -8389,7 +8445,7 @@ 'generate-temporaries '"invalid argument" x598) - (void))) + (voide))) ls596) (map (lambda (x597) (begin @@ -8400,7 +8456,7 @@ '((tmp))))) ls596)))) '0)) - (set! free-identifier=? + (set! sc-free-identifier=? (lambda (x592 y591) (begin ((lambda (x594) @@ -8409,7 +8465,7 @@ 'free-identifier=? '"invalid argument" x594) - (void))) + (voide))) x592) ((lambda (x593) (if (not (nonsymbol-id?305 x593)) @@ -8417,10 +8473,10 @@ 'free-identifier=? '"invalid argument" x593) - (void))) + (voide))) y591) (free-id=?435 x592 y591)))) - (set! bound-identifier=? + (set! sc-bound-identifier=? (lambda (x588 y587) (begin ((lambda (x590) @@ -8429,7 +8485,7 @@ 'bound-identifier=? '"invalid argument" x590) - (void))) + (voide))) x588) ((lambda (x589) (if (not (nonsymbol-id?305 x589)) @@ -8437,7 +8493,7 @@ 'bound-identifier=? '"invalid argument" x589) - (void))) + (voide))) y587) (bound-id=?438 x588 y587)))) (set! literal-identifier=? @@ -8449,7 +8505,7 @@ 'literal-identifier=? '"invalid argument" x586) - (void))) + (voide))) x584) ((lambda (x585) (if (not (nonsymbol-id?305 x585)) @@ -8457,10 +8513,10 @@ 'literal-identifier=? '"invalid argument" x585) - (void))) + (voide))) y583) (literal-id=?436 x584 y583)))) - (set! syntax-error + (set! sc-syntax-error (lambda (object578 . messages579) (begin (for-each @@ -8471,7 +8527,7 @@ 'syntax-error '"invalid argument" x582) - (void))) + (voide))) x581)) messages579) ((lambda (message580) @@ -8483,7 +8539,7 @@ (letrec ((match-each525 (lambda (e575 p574 w573) (if (annotation?132 e575) (match-each525 - (annotation-expression e575) + (sc-annotation-expression e575) p574 w573) (if (pair? e575) @@ -8564,7 +8620,7 @@ (if (annotation?132 e568) (f566 - (annotation-expression + (sc-annotation-expression e568) w567) (if (syntax-object?64 @@ -8590,7 +8646,7 @@ (match-each-any527 (lambda (e558 w557) (if (annotation?132 e558) (match-each-any527 - (annotation-expression e558) + (sc-annotation-expression e558) w557) (if (pair? e558) ((lambda (l559) @@ -8668,7 +8724,7 @@ p555 '1) r554) - (void)))))) + (voide)))))) (vector-ref p555 '0)))))))) @@ -8799,7 +8855,7 @@ w543 r542) '#f) - (void))))))) + (voide))))))) (vector-ref p544 '0))))))) (match531 (lambda (e539 p538 w537 r536) (if (not r536) @@ -8810,7 +8866,7 @@ (match*530 ((lambda (e540) (if (annotation?132 e540) - (annotation-expression + (sc-annotation-expression e540) e540)) (syntax-object-expression65 @@ -8823,7 +8879,7 @@ (match*530 ((lambda (e541) (if (annotation?132 e541) - (annotation-expression + (sc-annotation-expression e541) e541)) e539) @@ -8838,7 +8894,7 @@ (match*530 ((lambda (e534) (if (annotation?132 e534) - (annotation-expression e534) + (sc-annotation-expression e534) e534)) (syntax-object-expression65 e533)) p532 @@ -8847,7 +8903,7 @@ (match*530 ((lambda (e535) (if (annotation?132 e535) - (annotation-expression e535) + (sc-annotation-expression e535) e535)) e533) p532 @@ -8895,7 +8951,7 @@ '#(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))) (cons e12547 e22546))))) tmp2545) - (syntax-error tmp2532))) + (sc-syntax-error tmp2532))) ($syntax-dispatch tmp2532 '(any #(each (any any)) any . each-any))))) @@ -8913,7 +8969,7 @@ (if (if tmp2556 (apply (lambda (dummy2561 tid2560 id2559 e12558 e22557) - (andmap identifier? (cons tid2560 id2559))) + (sc-andmap sc-identifier? (cons tid2560 id2559))) tmp2556) '#f) (apply @@ -8951,7 +9007,7 @@ id2565) (cons e12564 e22563))))) tmp2556) - (syntax-error tmp2555))) + (sc-syntax-error tmp2555))) ($syntax-dispatch tmp2555 '(any (any . each-any) any . each-any)))) @@ -8971,7 +9027,7 @@ '#(syntax-object syntax ((top) #(ribcage #(dummy x) #(("m" top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t))) x2573))) tmp2572) - (syntax-error tmp2571))) + (sc-syntax-error tmp2571))) ($syntax-dispatch tmp2571 '(any any)))) x2570)) '*top*) @@ -9010,7 +9066,7 @@ template2599))) tmp2598) ((lambda (_2603) - (syntax-error x2575)) + (sc-syntax-error x2575)) tmp2593))) ($syntax-dispatch tmp2593 @@ -9024,7 +9080,7 @@ (if (if tmp2578 (apply (lambda (_2581 k2580 cl2579) - (andmap identifier? k2580)) + (sc-andmap sc-identifier? k2580)) tmp2578) '#f) (apply @@ -9043,11 +9099,11 @@ '#(syntax-object x ((top) #(ribcage #(cl) #((top)) #("i")) #(ribcage #(_ k cl) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (clause) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))) (cons k2584 cl2589))))) tmp2588) - (syntax-error tmp2586))) + (sc-syntax-error tmp2586))) ($syntax-dispatch tmp2586 'each-any))) (map clause2576 cl2583))) tmp2578) - (syntax-error tmp2577))) + (sc-syntax-error tmp2577))) ($syntax-dispatch tmp2577 '(any each-any . each-any)))) x2575))) '*top*) @@ -9082,7 +9138,7 @@ '#(syntax-object or ((top) #(ribcage #(_ e1 e2 e3) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))) (cons e22613 e32612))))) tmp2611) - (syntax-error tmp2605))) + (sc-syntax-error tmp2605))) ($syntax-dispatch tmp2605 '(any any any . each-any))))) @@ -9117,7 +9173,7 @@ (lambda (_2629) '#(syntax-object #t ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))) tmp2628) - (syntax-error tmp2618))) + (sc-syntax-error tmp2618))) ($syntax-dispatch tmp2618 '(any))))) ($syntax-dispatch tmp2618 '(any any))))) ($syntax-dispatch tmp2618 '(any any any . each-any)))) @@ -9131,7 +9187,7 @@ (if (if tmp2632 (apply (lambda (_2637 x2636 v2635 e12634 e22633) - (andmap identifier? x2636)) + (sc-andmap sc-identifier? x2636)) tmp2632) '#f) (apply @@ -9146,7 +9202,7 @@ (if (if tmp2647 (apply (lambda (_2653 f2652 x2651 v2650 e12649 e22648) - (andmap identifier? (cons f2652 x2651))) + (sc-andmap sc-identifier? (cons f2652 x2651))) tmp2647) '#f) (apply @@ -9163,7 +9219,7 @@ f2659) v2657)) tmp2647) - (syntax-error tmp2631))) + (sc-syntax-error tmp2631))) ($syntax-dispatch tmp2631 '(any any #(each (any any)) any . each-any))))) @@ -9180,7 +9236,7 @@ (if (if tmp2666 (apply (lambda (let*2671 x2670 v2669 e12668 e22667) - (andmap identifier? x2670)) + (sc-andmap sc-identifier? x2670)) tmp2666) '#f) (apply @@ -9201,7 +9257,7 @@ (list binding2683) body2684)) tmp2682) - (syntax-error tmp2681))) + (sc-syntax-error tmp2681))) ($syntax-dispatch tmp2681 '(any any)))) @@ -9211,7 +9267,7 @@ f2678) (map list x2676 v2675))) tmp2666) - (syntax-error tmp2665))) + (sc-syntax-error tmp2665))) ($syntax-dispatch tmp2665 '(any #(each (any any)) any . each-any)))) @@ -9286,7 +9342,7 @@ e22707)))) tmp2706) ((lambda (_2711) - (syntax-error + (sc-syntax-error x2687)) tmp2696))) ($syntax-dispatch @@ -9365,7 +9421,7 @@ rest2713)) tmp2720) ((lambda (_2725) - (syntax-error + (sc-syntax-error x2687)) tmp2714))) ($syntax-dispatch @@ -9390,7 +9446,7 @@ m12691 m22690)) tmp2689) - (syntax-error tmp2688))) + (sc-syntax-error tmp2688))) ($syntax-dispatch tmp2688 '(any any . each-any)))) x2687)) '*top*) @@ -9458,14 +9514,14 @@ '#(syntax-object do ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i")) #(top-ribcage *top* #t))) step2748))))))) tmp2756) - (syntax-error tmp2749))) + (sc-syntax-error tmp2749))) ($syntax-dispatch tmp2749 '(any . each-any))))) ($syntax-dispatch tmp2749 '()))) e12731)) tmp2747) - (syntax-error tmp2737))) + (sc-syntax-error tmp2737))) ($syntax-dispatch tmp2737 'each-any))) (map (lambda (v2741 s2740) ((lambda (tmp2742) @@ -9478,7 +9534,7 @@ (lambda (e2745) e2745) tmp2744) ((lambda (_2746) - (syntax-error orig-x2727)) + (sc-syntax-error orig-x2727)) tmp2742))) ($syntax-dispatch tmp2742 '(any))))) ($syntax-dispatch tmp2742 '()))) @@ -9486,7 +9542,7 @@ var2735 step2733))) tmp2729) - (syntax-error tmp2728))) + (sc-syntax-error tmp2728))) ($syntax-dispatch tmp2728 '(any #(each (any any . any)) @@ -9723,7 +9779,7 @@ (lambda () '#(syntax-object ("quote" ()) ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t)))) tmp2898) - (syntax-error tmp2884))) + (sc-syntax-error tmp2884))) ($syntax-dispatch tmp2884 '())))) ($syntax-dispatch tmp2884 '(any . any)))) p2883))) @@ -9810,7 +9866,7 @@ any)))) y2868)) tmp2867) - (syntax-error tmp2866))) + (sc-syntax-error tmp2866))) ($syntax-dispatch tmp2866 '(any any)))) (list x2865 y2864)))) (quasiappend2767 (lambda (x2851 y2850) @@ -9832,7 +9888,7 @@ '#(syntax-object "append" ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t))) p2856)) tmp2855) - (syntax-error + (sc-syntax-error tmp2854))) ($syntax-dispatch tmp2854 @@ -9855,7 +9911,7 @@ (list y2861)))) tmp2860) - (syntax-error + (sc-syntax-error tmp2859))) ($syntax-dispatch tmp2859 @@ -9963,7 +10019,7 @@ '#(syntax-object "vector" ((top) #(ribcage #(t8) #(("m" tmp)) #("i")) #(ribcage () () ()) #(ribcage #(ls) #((top)) #("i")) #(ribcage #(_) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t))) t82844)) tmp2843) - (syntax-error + (sc-syntax-error tmp2842))) ($syntax-dispatch tmp2842 @@ -9997,7 +10053,7 @@ '#(syntax-object list ((top) #(ribcage #(t1) #(("m" tmp)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t))) t12785)) tmp2784) - (syntax-error + (sc-syntax-error tmp2782))) ($syntax-dispatch tmp2782 @@ -10024,7 +10080,7 @@ t32795 t22794)) tmp2793) - (syntax-error + (sc-syntax-error tmp2792))) ($syntax-dispatch tmp2792 @@ -10050,7 +10106,7 @@ '#(syntax-object append ((top) #(ribcage #(t4) #(("m" tmp)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t))) t42802)) tmp2801) - (syntax-error + (sc-syntax-error tmp2799))) ($syntax-dispatch tmp2799 @@ -10071,7 +10127,7 @@ '#(syntax-object vector ((top) #(ribcage #(t5) #(("m" tmp)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (emit quasivector quasilist* quasiappend quasicons vquasi quasi) ((top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i")) #(top-ribcage *top* #t))) t52809)) tmp2808) - (syntax-error + (sc-syntax-error tmp2806))) ($syntax-dispatch tmp2806 @@ -10098,7 +10154,7 @@ (lambda (x2816) x2816) tmp2815) - (syntax-error + (sc-syntax-error tmp2777))) ($syntax-dispatch tmp2777 @@ -10141,17 +10197,17 @@ (apply (lambda (_2775 e2774) (emit2770 (quasi2764 e2774 '0))) tmp2773) - (syntax-error tmp2772))) + (sc-syntax-error tmp2772))) ($syntax-dispatch tmp2772 '(any any)))) x2771))))) '*top*) ($sc-put-cte '#(syntax-object unquote ((top) #(ribcage #(unquote) #((top)) #(unquote)))) - (lambda (x2923) (syntax-error x2923 '"misplaced")) + (lambda (x2923) (sc-syntax-error x2923 '"misplaced")) '*top*) ($sc-put-cte '#(syntax-object unquote-splicing ((top) #(ribcage #(unquote-splicing) #((top)) #(unquote-splicing)))) - (lambda (x2924) (syntax-error x2924 '"misplaced")) + (lambda (x2924) (sc-syntax-error x2924 '"misplaced")) '*top*) ($sc-put-cte '#(syntax-object quasisyntax ((top) #(ribcage #(quasisyntax) #((top)) #(quasisyntax)))) @@ -10255,12 +10311,12 @@ b*2975) t3004)) tmp3003) - (syntax-error + (sc-syntax-error tmp3002))) ($syntax-dispatch tmp3002 '(any)))) - (generate-temporaries + (sc-generate-temporaries (list q3001)))) tmp2999) @@ -10301,12 +10357,12 @@ tmp3016)) dnew3010))) tmp3014) - (syntax-error + (sc-syntax-error tmp3012))) ($syntax-dispatch tmp3012 'each-any))) - (generate-temporaries + (sc-generate-temporaries q3009))))) tmp3005) ((lambda (tmp3021) @@ -10359,7 +10415,7 @@ tmp3036)) dnew3026)) tmp3034) - (syntax-error + (sc-syntax-error tmp3032))) ($syntax-dispatch tmp3032 @@ -10371,12 +10427,12 @@ '(#(syntax-object ... ((top) #(ribcage #(t) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b* dnew) #((top) (top)) #("i" "i")) #(ribcage #(q d) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(q n b* k) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))))) t3031)))) tmp3030) - (syntax-error + (sc-syntax-error tmp3028))) ($syntax-dispatch tmp3028 'each-any))) - (generate-temporaries + (sc-generate-temporaries q3025))))) tmp3021) ((lambda (tmp3042) @@ -10414,7 +10470,7 @@ a3052 d3051)) tmp3050) - (syntax-error + (sc-syntax-error tmp3049))) ($syntax-dispatch tmp3049 @@ -10462,7 +10518,7 @@ (list->vector x3063)) tmp3062) - (syntax-error + (sc-syntax-error tmp3061))) ($syntax-dispatch tmp3061 @@ -10555,12 +10611,12 @@ t2952 xnew*2943))) tmp2951) - (syntax-error + (sc-syntax-error tmp2949))) ($syntax-dispatch tmp2949 'each-any))) - (generate-temporaries + (sc-generate-temporaries q2948))) tmp2946) ((lambda (tmp2956) @@ -10600,7 +10656,7 @@ m2966) xnew*2943)) tmp2965) - (syntax-error + (sc-syntax-error tmp2963))) ($syntax-dispatch tmp2963 @@ -10612,12 +10668,12 @@ '(#(syntax-object ... ((top) #(ribcage #(t) #((top)) #("i")) #(ribcage #(q) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b* xnew*) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x* n b* k) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t)))))) t2962)))) tmp2961) - (syntax-error + (sc-syntax-error tmp2959))) ($syntax-dispatch tmp2959 'each-any))) - (generate-temporaries + (sc-generate-temporaries q2958))) tmp2956) ((lambda (_2971) @@ -10672,23 +10728,23 @@ '#(syntax-object syntax ((top) #(ribcage #(b x) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(b* xnew) #((top) (top)) #("i" "i")) #(ribcage #(_ x) #((top) (top)) #("i" "i")) #(ribcage (vqs qs) ((top) (top)) ("i" "i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))) x2936))) tmp2935) - (syntax-error tmp2934))) + (sc-syntax-error tmp2934))) ($syntax-dispatch tmp2934 '(each-any any)))) (list b*2933 xnew2932)))))) tmp2929) - (syntax-error tmp2928))) + (sc-syntax-error tmp2928))) ($syntax-dispatch tmp2928 '(any any)))) x2925))) '*top*) ($sc-put-cte '#(syntax-object unsyntax ((top) #(ribcage #(unsyntax) #((top)) #(unsyntax)))) - (lambda (x3067) (syntax-error x3067 '"misplaced")) + (lambda (x3067) (sc-syntax-error x3067 '"misplaced")) '*top*) ($sc-put-cte '#(syntax-object unsyntax-splicing ((top) #(ribcage #(unsyntax-splicing) #((top)) #(unsyntax-splicing)))) - (lambda (x3068) (syntax-error x3068 '"misplaced")) + (lambda (x3068) (sc-syntax-error x3068 '"misplaced")) '*top*) ($sc-put-cte '#(syntax-object include ((top) #(ribcage #(include) #((top)) #(include)))) @@ -10726,12 +10782,12 @@ '#(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i")) #(top-ribcage *top* #t))) exp3078)) tmp3077) - (syntax-error tmp3076))) + (sc-syntax-error tmp3076))) ($syntax-dispatch tmp3076 'each-any))) (read-file3070 fn3075 k3074))) (syntax-object->datum filename3073))) tmp3072) - (syntax-error tmp3071))) + (sc-syntax-error tmp3071))) ($syntax-dispatch tmp3071 '(any any)))) x3069))) '*top*) @@ -10788,7 +10844,7 @@ e23102)))) tmp3101) ((lambda (_3107) - (syntax-error + (sc-syntax-error x3085)) tmp3096))) ($syntax-dispatch @@ -10830,7 +10886,7 @@ rest3109)) tmp3111) ((lambda (_3117) - (syntax-error + (sc-syntax-error x3085)) tmp3110))) ($syntax-dispatch @@ -10848,7 +10904,7 @@ m13089 m23088))) tmp3087) - (syntax-error tmp3086))) + (sc-syntax-error tmp3086))) ($syntax-dispatch tmp3086 '(any any any . each-any)))) x3085)) '*top*) @@ -10889,8 +10945,8 @@ (apply (lambda (dummy3131 id3130 exp13129 var3128 val3127 exp23126) - (if (identifier? id3130) - (identifier? var3128) + (if (sc-identifier? id3130) + (sc-identifier? var3128) '#f)) tmp3125) '#f) @@ -10937,7 +10993,7 @@ '#(syntax-object syntax ((top) #(ribcage #(dummy id exp1 var val exp2) #(("m" top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #(("m" top)) #("i")) #(top-ribcage *top* #t))) exp13135)))))) tmp3125) - (syntax-error tmp3121))) + (sc-syntax-error tmp3121))) ($syntax-dispatch tmp3121 '(any (any any) @@ -10950,34 +11006,6 @@ x3120)) '*top*) -(define env (scheme-report-environment 5)) - -(define (sc-eval e) - (eval (cadr e) env)) - -(eval `(define syntax-object->datum ,syntax-object->datum) env) -(eval `(define datum->syntax-object ,datum->syntax-object) env) -(eval `(define syntax->list ,syntax->list) env) -(eval `(define syntax->vector ,syntax->vector) env) -(eval `(define identifier? ,identifier?) env) -(eval `(define free-identifier=? ,free-identifier=?) env) -(eval `(define bound-identifier=? ,bound-identifier=?) env) -(eval `(define literal-identifier=? ,literal-identifier=?) env) -(eval `(define generate-temporaries ,generate-temporaries) env) -(eval `(define environment? ,environment?) env) -(eval `(define syntax-error ,syntax-error) env) -(eval `(define $sc-put-cte ,$sc-put-cte) env) -(eval `(define $syntax-dispatch ,$syntax-dispatch) env) -(eval `(define $make-environment ,$make-environment) env) -(eval `(define sc-expand ,sc-expand) env) -(eval `(define andmap ,andmap) env) -(eval `(define ormap ,ormap) env) -(eval `(define gensym ,gensym) env) -(eval `(define gensym? ,gensym?) env) - -(eval `(define eval ,sc-eval) env) -(eval `(define interaction-environment ,sc-interaction-environment) env) - (time (with-input-from-file "psyntax-input.txt" (lambda () diff --git a/collects/tests/mzscheme/benchmarks/common/psyntax.ss b/collects/tests/mzscheme/benchmarks/common/psyntax.ss index 2e6d5b82c2..e5d40e6426 100644 --- a/collects/tests/mzscheme/benchmarks/common/psyntax.ss +++ b/collects/tests/mzscheme/benchmarks/common/psyntax.ss @@ -1,6 +1,6 @@ #lang r5rs (#%require scheme/include - (only scheme/base time current-directory) + (only scheme/base time current-directory error) (only mzlib/etc this-expression-source-directory)) (current-directory (this-expression-source-directory)) (include "psyntax.sch") diff --git a/collects/tests/mzscheme/benchmarks/common/puzzle.sch b/collects/tests/mzscheme/benchmarks/common/puzzle.sch index 9120df4e17..47cbc60208 100644 --- a/collects/tests/mzscheme/benchmarks/common/puzzle.sch +++ b/collects/tests/mzscheme/benchmarks/common/puzzle.sch @@ -30,8 +30,9 @@ (define *piecemax* (make-vector (+ typemax 1) 0)) (define *puzzle* (make-vector (+ size 1))) (define *p* (make-vector (+ typemax 1))) -(for-each (lambda (i) (vector-set! *p* i (make-vector (+ size 1)))) - (iota (+ typemax 1))) +(define nothing + (for-each (lambda (i) (vector-set! *p* i (make-vector (+ size 1)))) + (iota (+ typemax 1)))) (define (fit i j) (let ((end (vector-ref *piecemax* i))) diff --git a/collects/tests/mzscheme/benchmarks/common/scheme.sch b/collects/tests/mzscheme/benchmarks/common/scheme.sch index 9761ad7df7..ac891d530d 100644 --- a/collects/tests/mzscheme/benchmarks/common/scheme.sch +++ b/collects/tests/mzscheme/benchmarks/common/scheme.sch @@ -856,6 +856,8 @@ (scheme-global-var name) value)) +(define nothing + (begin (def-proc 'not (lambda (x) (not x))) (def-proc 'boolean? boolean?) (def-proc 'eqv? eqv?) @@ -1032,7 +1034,7 @@ (def-proc 'write write) (def-proc 'display display) (def-proc 'newline newline) -(def-proc 'write-char write-char) +(def-proc 'write-char write-char))) ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/collects/tests/mzscheme/benchmarks/common/scheme2.sch b/collects/tests/mzscheme/benchmarks/common/scheme2.sch index 9a307fbb85..934b5783ec 100644 --- a/collects/tests/mzscheme/benchmarks/common/scheme2.sch +++ b/collects/tests/mzscheme/benchmarks/common/scheme2.sch @@ -862,6 +862,8 @@ (scheme-global-var name) value)) +(define nothing + (begin (def-proc 'not (lambda (x) (not x))) (def-proc 'boolean? boolean?) (def-proc 'eqv? eqv?) @@ -1038,7 +1040,7 @@ (def-proc 'write write) (def-proc 'display display) (def-proc 'newline newline) -(def-proc 'write-char write-char) +(def-proc 'write-char write-char))) ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/collects/tests/mzscheme/benchmarks/common/scheme48-prelude.sch b/collects/tests/mzscheme/benchmarks/common/scheme48-prelude.sch new file mode 100644 index 0000000000..1e6fcd4986 --- /dev/null +++ b/collects/tests/mzscheme/benchmarks/common/scheme48-prelude.sch @@ -0,0 +1,22 @@ +(define (time* thunk) + (let ((start-cpu (run-time)) + (start-real (real-time))) + (let ((result (thunk))) + (let ((end-cpu (run-time)) + (end-real (real-time))) + (let ((cpu (- end-cpu start-cpu)) + (real (- end-real start-real))) + (display "cpu time: ") + (display cpu) + (display " real time: ") + (display real) + (newline) + result))))) + +(define-syntax time + (syntax-rules () + ((_ expr) (time* (lambda () expr))))) + +(define (error . args) (+ 1 args)) + + diff --git a/collects/tests/mzscheme/benchmarks/common/tabulate.ss b/collects/tests/mzscheme/benchmarks/common/tabulate.ss index 0b2d41d103..019d7200b0 100755 --- a/collects/tests/mzscheme/benchmarks/common/tabulate.ss +++ b/collects/tests/mzscheme/benchmarks/common/tabulate.ss @@ -3,28 +3,49 @@ exec mzscheme -qu "$0" ${1+"$@"} |# +;; Input format is a sequence of S-expression forms: +;; ( ( ) ) +;; where +;; * is a symbol for an implementation; it can optionally be of the form +;; @, where each is tried in each +;; * is a symbol for the benchmark +;; * and are the run times (CPU and real) in milliseconds +;; * can be #f, or it can be a portion of spent GCing +;; * should be the same for each entry of a particular +;; and combination; it is the time to compile the benchmark + (module tabulate mzscheme (require mzlib/list xml/xml - mzlib/cmdline) + mzlib/cmdline + (only scheme/list argmin)) (define base-link-filename (make-parameter #f)) (define full-page-mode (make-parameter #f)) (define include-links (make-parameter #f)) (define nongc (make-parameter #f)) + (define subtract-nothing (make-parameter #f)) + (define generate-graph (make-parameter #f)) + (define no-compile-time (make-parameter #f)) (command-line "tabulate" (current-command-line-arguments) (once-each - [("--no-links") "suppress benchmark links to SVN" - (include-links #f)] + [("--graph") "generate graphs instead of tables (unless --multi)" + (generate-graph #t)] + [("--links") "benchmark links to SVN" + (include-links #t)] [("--multi") name "generate multiple pages for different views of data" (base-link-filename name)] + [("--no-compile-time") "do not show compile times" + (no-compile-time #t)] [("--nongc") "show times not including GC" (nongc #t)] [("--index") "generate full page with an index.html link" - (full-page-mode #t)])) + (full-page-mode #t)] + [("--nothing") "subtract compilation time of nothing benchmark" + (subtract-nothing #t)])) (define bm-table (make-hash-table)) (define impls (make-hash-table)) @@ -54,21 +75,55 @@ exec mzscheme -qu "$0" ${1+"$@"} (define average-runs (map (lambda (bm-run) - (cons - (car bm-run) - (map (lambda (runs) - (list (car runs) - (list (average caar (cdr runs)) - (average cadar (cdr runs)) - (average caddar (cdr runs))) - (cadadr runs))) - (hash-table-map (cdr bm-run) cons)))) - bm-runs)) + (let* ([runss (hash-table-map (cdr bm-run) cons)]) + (cons + (car bm-run) + (map (lambda (runs) + (list (car runs) + (list (average caar (cdr runs)) + (average cadar (cdr runs)) + (average caddar (cdr runs))) + (let ([nothing-compile-time + (if (subtract-nothing) + (let ([a (hash-table-get + (hash-table-get bm-table 'nothing #hash()) + (car runs) + #f)]) + (if a + (cadar a) + 0)) + 0)]) + (max (- (or (cadadr runs) 0) + nothing-compile-time) + 0)))) + runss)))) + (if (subtract-nothing) + (filter (lambda (v) + (not (eq? (car v) 'nothing))) + bm-runs) + bm-runs))) (define (symbolstring a) (symbol->string b))) + (define (modestring impl)]) + (cond + [(regexp-match #rx"^(.*)@(.*)" s) + => (lambda (m) + (if (eq? grouping 'impl) + (cadr m) + (caddr m)))] + [else s]))) + (define sorted-runs (sort average-runs (lambda (a b) (symbolstring r) (if (integer? r) (number->string r) @@ -87,147 +151,374 @@ exec mzscheme -qu "$0" ${1+"$@"} (size "-2")) ,s)) - (define (lookup-color impl) - (let loop ([impls sorted-impls][odd? #f]) - (if (eq? (car impls) impl) - (if odd? - "#EEEEFF" - "#DDFFDD") - (loop (cdr impls) (not odd?))))) - - (define (wrap-page relative-to p) + (define (wrap-page relative-to . ps) (if (full-page-mode) - (let ([title (format "~a normalized to ~a" + (let ([title (format "~a normalized to ~a~a" (or (base-link-filename) "results") + (if (string? relative-to) + "fastest " + "") (or relative-to "fastest"))]) `(html (head (title ,title) (body - (h1 ,title) - (p "See also " (a ((href "index.html")) - "about the benchmarks") - ".") - (p ,p))))) - p)) + (p + (b ,title ".") + " See also " (a ((href "index.html")) + "about the benchmarks") + ".") + ,@(map (lambda (p) `(p ,p)) + ps))))) + `(html (nbody ,@ps)))) (define forever 1000000000) (define (ntime v) - (and (caadr v) (- (caadr v) (caddr (cadr v))))) + (and (caadr v) (- (caadr v) (or (caddr (cadr v)) 0)))) - (define (generate-page relative-to) + (define (grouping->suffix grouping) + (if (eq? grouping 'impl) + "" + (format "-~a" grouping))) + + (define no-modes? (equal? mode-sorted-impls sorted-impls)) + + (define (fixup-filename s) + (regexp-replace* #rx"[^.a-zA-Z0-9-]" s (lambda (s) + (format "_~x" (char->integer (string-ref s 0)))))) + + (define (output-name impl grouping graph?) + (fixup-filename + (if impl + (format "~a-~a~a.html" + (base-link-filename) + impl + (grouping->suffix grouping)) + (format "~a~a~a.html" + (base-link-filename) + (grouping->suffix grouping) + (if graph? "-plot" ""))))) + + (define (resolve-relative-to relative-to grouping runs) + (if (string? relative-to) + ;; Find fastest among entries matching `relative-to': + (car (argmin (lambda (run) + (or (caadr run) forever)) + (cons (list #f (list #f #f #f) #f) + (filter (lambda (run) + (equal? relative-to (extract-column (car run) grouping))) + runs)))) + ;; Nothing to resolve: + relative-to)) + + (define (extract-variants grouping impls) + (let ([ht (make-hash-table 'equal)]) + (for-each (lambda (impl) + (hash-table-put! ht (extract-column impl grouping) #t)) + impls) + (hash-table-map ht (lambda (k v) k)))) + + (define just-impls (sort (extract-variants 'impl sorted-impls) stringstring name)) + (td + (table + ((style "border-spacing: 0px;")) + ,@(content))))) + + (define (bar-plot impl n ratio) + `(tr (td (span ((style "font-size: small;")) + ,(symbol->string impl)) + nbsp) + (td ((style "padding: 0em;")) + ,(if (and n ratio) + (let ([col (darken (lookup-color impl))]) + `(span ((style ,(format "background-color: ~a; color: ~a;" col col))) + ,(format (make-string (max (floor (* 60 (if (zero? n) 1 ratio))) + 1) + #\x)))) + "")))) + + (define (generate-page relative-to grouping graph? has-other?) (empty-tag-shorthand html-empty-tags) (write-xml/content (xexpr->xml (wrap-page relative-to - `(table - (tr (td nbsp) - (td ((colspan "2") (align "right")) - ,(if (and (base-link-filename) - relative-to) - `(a ((href ,(format "~a.html" (base-link-filename)))) - "fastest") - "fastest")) - ,@(map (lambda (impl) - `(td ((colspan "2") (align "right")) - (b ,(let ([s (symbol->string impl)]) - (if (and (base-link-filename) - (not (eq? impl relative-to))) - `(a ((href ,(format "~a-~a.html" - (base-link-filename) - impl))) - ,s) - s))) - nbsp)) - sorted-impls)) - ,@(map (lambda (bm-run) - (let ([fastest (apply min (map (lambda (run) - (or (caadr run) forever)) - (cdr bm-run)))] - [n-fastest (apply min (map (lambda (run) - (or (ntime run) forever)) - (cdr bm-run)))] - [c-fastest (apply min (map (lambda (run) - (let ([v (caddr run)]) - (or (and v (positive? v) v) - forever))) - (cdr bm-run)))]) - (let-values ([(base n-base c-base) - (if relative-to - (let ([a (assq relative-to (cdr bm-run))]) - (if a - (values (caadr a) (ntime a) (caddr a)) - (values #f #f #f))) - (values fastest n-fastest c-fastest))]) - `(tr (td ,(if (include-links) - `(a ((href ,(format (string-append "http://svn.plt-scheme.org/plt/trunk/collects/" - "tests/mzscheme/benchmarks/common/~a.sch") - (car bm-run)))) - ,(symbol->string (car bm-run))) - (symbol->string (car bm-run)))) - (td ((align "right")) - nbsp - ,(small (if (= c-fastest forever) - " " - (number->string c-fastest))) - nbsp) - (td ((align "right")) - ,(format "~a ms" fastest) - nbsp nbsp) - ,@(apply - append - (map (lambda (impl) - (let* ([a (assq impl (cdr bm-run))] - [n (and a (caadr a))] - [n2 (and a (ntime a))]) - `(,(if (= c-fastest forever) - `(td) - `(td ((align "right") - (bgcolor ,(lookup-color impl))) - ,(if (and (caddr a) c-base (positive? c-base)) - (small (ratio->string (/ (caddr a) c-base))) - '"-") - nbsp)) - (td ((bgcolor ,(lookup-color impl))) - ,(if (and n base) - (let ([s (if (= n base) - "1" - (if (zero? base) - "*" - (ratio->string (/ n base))))]) - (if (= n fastest) - `(font ((color "forestgreen")) (b ,s)) - s)) - "-") - ,@(if (nongc) - `(" / " - ,(if (and n2 n-base) - (let ([s (if (zero? base) + (if (not graph?) + `(table + ,@(if no-modes? + null + (list + `(tr + (td (i ,(if (eq? grouping 'mode) + "mode" + "impl"))) + (td nbsp) + (td nbsp) + ,@(let loop ([impls (if (eq? grouping 'mode) + mode-sorted-impls + sorted-impls)]) + (if (null? impls) + null + (let* ([impl (car impls)] + [s (extract-column impl grouping)] + [count (let loop ([impls (cdr impls)]) + (cond + [(null? impls) 0] + [(not (equal? s (extract-column (car impls) grouping))) + 0] + [else (add1 (loop (cdr impls)))]))]) + (cons + `(td ((colspan ,(number->string (* (if (no-compile-time) 1 2) (+ 1 count)))) + (align "center") + (bgcolor "#DDDDFF")) + (b ,(if (equal? s relative-to) + s + `(a ([href ,(fixup-filename + (format "~a-~a~a.html" + (base-link-filename) + s + (grouping->suffix grouping)))]) + ,s)))) + (loop (list-tail impls (+ 1 count)))))))))) + (tr (td ,(if no-modes? + 'nbsp + `(i (a ([href ,(output-name #f (opposite grouping) #f)]) + ,(if (eq? grouping 'mode) + "impl" + "mode"))))) + (td ((colspan ,(if (no-compile-time) "1" "2")) (align "right")) + ,(if (and (base-link-filename) + relative-to) + `(a ((href ,(fixup-filename + (format "~a~a.html" + (base-link-filename) + (grouping->suffix grouping))))) + "fastest") + "fastest")) + ,@(map (lambda (impl) + `(td ((colspan ,(if (no-compile-time) "1" "2")) (align "right")) + (b ,(let ([s (extract-column impl (opposite grouping))]) + (if (and (base-link-filename) + (not (eq? impl relative-to))) + `(a ((href ,(fixup-filename + (format "~a-~a~a.html" + (base-link-filename) + impl + (grouping->suffix grouping))))) + ,s) + s))) + nbsp)) + (if (eq? grouping 'mode) + mode-sorted-impls + sorted-impls)) + ,@(if has-other? + `((td nbsp nbsp (a ((href ,(output-name #f 'impl #t))) "To plots"))) + null)) + ,@(map (lambda (bm-run) + (define orig-relative-to relative-to) + (call-with-bm-info + bm-run + relative-to + grouping + (lambda (fastest n-fastest c-fastest relative-to + base n-base c-base) + `(tr (td ,(if (include-links) + `(a ((href ,(format (string-append "http://svn.plt-scheme.org/plt/trunk/collects/" + "tests/mzscheme/benchmarks/common/~a.sch") + (car bm-run)))) + ,(symbol->string (car bm-run))) + (symbol->string (car bm-run)))) + ,@(if (no-compile-time) + null + `((td ((align "right")) + nbsp + ,(small (if (= c-fastest forever) + " " + (number->string c-fastest))) + nbsp))) + (td ((align "right")) + ,(format "~a ms" fastest) + nbsp nbsp) + ,@(apply + append + (map (lambda (impl) + (let* ([a (assq impl (cdr bm-run))] + [n (and a (caadr a))] + [n2 (and a (ntime a))]) + `(,@(if (no-compile-time) + null + (list + (if (= c-fastest forever) + `(td) + `(td ((align "right") + (bgcolor ,(lookup-color impl))) + ,(if (and a (caddr a) c-base (positive? c-base)) + (small (ratio->string (/ (caddr a) c-base))) + '"-") + nbsp)))) + (td ((bgcolor ,(if (and n base (= n base) + (or (not orig-relative-to) + (and (string? orig-relative-to) + (equal? (extract-column impl grouping) + orig-relative-to)))) + "white" + (lookup-color impl))) + (align "right")) + ,(if (and n base) + (let ([s (if (= n base) + "1" + (if (zero? base) + "*" + (ratio->string (/ n base))))]) + (if (= n fastest) + `(font ((color "forestgreen")) (b ,s)) + s)) + "-") + ,@(if (nongc) + `(" / " + ,(if (and n2 n-base) + (let ([s (if (zero? base) "*" (ratio->string (/ n2 base)))]) - (if (= n2 n-fastest) - `(font ((color "forestgreen")) (b ,s)) - s)) - "-")) - null) - nbsp)))) - sorted-impls)))))) - sorted-runs))))) + (if (= n2 n-fastest) + `(font ((color "forestgreen")) (b ,s)) + s)) + "-")) + null) + nbsp)))) + (if (eq? grouping 'mode) + mode-sorted-impls + sorted-impls))))))) + sorted-runs)) + `(table + ((style "border-spacing: 0px 3px;")) + (tr (td ((colspan "2")) + "Longer is better." + ,@(if has-other? + `(nbsp nbsp (a ((href ,(output-name #f 'impl #f))) "Back to tables")) + null))) + ,(let* ([bm-runs (filter (lambda (bm-run) + (andmap (lambda (impl) + (let ([a (assq impl (cdr bm-run))]) + (and a (caadr a)))) + sorted-impls)) + sorted-runs)] + [rel-vals (map (lambda (bm-run) + (call-with-bm-info + bm-run + relative-to + grouping + (lambda (fastest n-fastest c-fastest relative-to + base n-base c-base) + (map (lambda (impl) + (let* ([a (assq impl (cdr bm-run))] + [n (and a (caadr a))]) + (list impl (if (zero? n) 1 (/ base n))))) + sorted-impls)))) + bm-runs)] + [avgs (map (lambda (impl) + (let ([vals (map (lambda (rel-val) (cadr (assq impl rel-val))) + rel-vals)]) + (sqrt (apply + (map (lambda (x) (* x x)) vals))))) + sorted-impls)] + [max-avg (apply max avgs)]) + (bar-group 'geometric-mean + (lambda () + (map (lambda (impl avg) + (bar-plot impl 1 (inexact->exact (/ avg max-avg)))) + sorted-impls avgs)))) + ,@(map (lambda (bm-run) + (call-with-bm-info + bm-run + relative-to + grouping + (lambda (fastest n-fastest c-fastest relative-to + base n-base c-base) + (bar-group + (car bm-run) + (lambda () + (map (lambda (impl) + (let* ([a (assq impl (cdr bm-run))] + [n (and a (caadr a))] + [n2 (and a (ntime a))]) + (bar-plot impl n (and n base (not (zero? n)) + (/ base n))))) + sorted-impls)))))) + sorted-runs)))))) (newline)) - + (if (base-link-filename) - (for-each (lambda (impl) - (with-output-to-file (if impl - (format "~a-~a.html" - (base-link-filename) - impl) - (format "~a.html" - (base-link-filename))) - (lambda () (generate-page impl)) - 'truncate)) - (cons #f sorted-impls)) - (generate-page #f))) + (begin + (for-each (lambda (grouping) + (for-each + (lambda (impl) + (let ([fn (output-name impl grouping #f)]) + (fprintf (current-error-port) "Generating ~a\n" fn) + (with-output-to-file fn + (lambda () (generate-page impl grouping #f #t)) + 'truncate))) + (append (cons #f sorted-impls) + (if no-modes? + null + (extract-variants grouping sorted-impls))))) + (if no-modes? + '(impl) + '(impl mode))) + (with-output-to-file (output-name #f 'impl #t) + (lambda () (generate-page #f 'impl #t #t)) + 'truncate)) + (generate-page #f 'impl (generate-graph) #f))) diff --git a/collects/tests/mzscheme/benchmarks/common/triangle.sch b/collects/tests/mzscheme/benchmarks/common/triangle.sch index cceb17ed77..baeddd2704 100644 --- a/collects/tests/mzscheme/benchmarks/common/triangle.sch +++ b/collects/tests/mzscheme/benchmarks/common/triangle.sch @@ -15,38 +15,17 @@ (define *board* (make-vector 16 1)) (define *sequence* (make-vector 14 0)) (define *a* (make-vector 37)) -(for-each (lambda (i x) (vector-set! *a* i x)) - '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 - 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36) - '(1 2 4 3 5 6 1 3 6 2 5 4 11 12 - 13 7 8 4 4 7 11 8 12 13 6 10 - 15 9 14 13 13 14 15 9 10 - 6 6)) (define *b* (make-vector 37)) -(for-each (lambda (i x) (vector-set! *b* i x)) - '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 - 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36) - '(2 4 7 5 8 9 3 6 10 5 9 8 - 12 13 14 8 9 5 2 4 7 5 8 - 9 3 6 10 5 9 8 12 13 14 - 8 9 5 5)) (define *c* (make-vector 37)) -(for-each (lambda (i x) (vector-set! *c* i x)) - '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 - 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36) - '(4 7 11 8 12 13 6 10 15 9 14 13 - 13 14 15 9 10 6 1 2 4 3 5 6 1 - 3 6 2 5 4 11 12 13 7 8 4 4)) (define *answer* '()) (define *final* '()) -(vector-set! *board* 5 0) - + (define (last-position) (do ((i 1 (+ i 1))) ((or (= i 16) (= 1 (vector-ref *board* i))) (if (= i 16) 0 i)))) -(define (try i depth) +(define (ttry i depth) (cond ((= depth 14) (let ((lp (last-position))) (if (not (member lp *final*)) @@ -63,7 +42,7 @@ (vector-set! *sequence* depth i) (do ((j 0 (+ j 1)) (depth (+ depth 1))) - ((or (= j 36) (try j depth)) #f)) + ((or (= j 36) (ttry j depth)) #f)) (vector-set! *board* (vector-ref *a* i) 1) (vector-set! *board* (vector-ref *b* i) 1) (vector-set! *board* (vector-ref *c* i) 0) '()) @@ -72,11 +51,33 @@ (define (gogogo i) (let ((*answer* '()) (*final* '())) - (try i 1))) + (ttry i 1))) + +(for-each (lambda (i x) (vector-set! *a* i x)) + '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 + 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36) + '(1 2 4 3 5 6 1 3 6 2 5 4 11 12 + 13 7 8 4 4 7 11 8 12 13 6 10 + 15 9 14 13 13 14 15 9 10 + 6 6)) +(for-each (lambda (i x) (vector-set! *b* i x)) + '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 + 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36) + '(2 4 7 5 8 9 3 6 10 5 9 8 + 12 13 14 8 9 5 2 4 7 5 8 + 9 3 6 10 5 9 8 12 13 14 + 8 9 5 5)) +(for-each (lambda (i x) (vector-set! *c* i x)) + '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 + 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36) + '(4 7 11 8 12 13 6 10 15 9 14 13 + 13 14 15 9 10 6 1 2 4 3 5 6 1 + 3 6 2 5 4 11 12 13 7 8 4 4)) +(vector-set! *board* 5 0) ;;; call: (gogogo 22)) -(time (let loop ((n 10000)) +(time (let loop ((n 100000)) (if (zero? n) 'done (begin diff --git a/collects/tests/mzscheme/future.ss b/collects/tests/mzscheme/future.ss new file mode 100644 index 0000000000..01ba92b82e --- /dev/null +++ b/collects/tests/mzscheme/future.ss @@ -0,0 +1,110 @@ +(load-relative "loadtest.ss") + +(Section 'future) +(require scheme/future) + +;; ---------------------------------------- + +(test 2 + touch + (future (λ () + 2))) + +(let ([f1 (future (λ () (+ 2 2)))] + [f2 (future (λ () (+ 5 3)))]) + (test 12 + (touch f2) (touch f1))) + +(let* ([v 5] + [f1 (future (λ () + (set! v 10) + v))]) + (test 10 touch f1)) + +(define (build-rand-list lst len) + (case len + [(0) lst] + [else + (build-rand-list (cons + (random) + lst) + (- len 1))])) + +(define (append-list-of-lists acc lst) + (cond + [(empty? lst) acc] + [else + (append-list-of-lists + (append acc (first lst)) + (rest lst))])) + +(let* ([nums '()] + [f1 (future (λ () + (build-rand-list nums 10)))]) + (set! nums (touch f1)) + (test 20 length (touch (future (λ () + (build-rand-list nums 10)))))) + +(let* ([f1 (future (λ () + (build-rand-list '() 20)))] + [f2 (future (λ () (length (touch f1))))]) + (test 20 touch f2)) + +(test 50000 'test7 + (let ([fts (for/list ([i (in-range 0 10000)]) + (future (λ () (build-rand-list '() 5))))]) + (length (append-list-of-lists '() (map touch fts))))) + +(test 31 'test8 + (let* ([f1 (future (λ () (foldl + 0 '(1 2 3 4 5))))] + [f2 (future (λ () (+ (touch + (future (λ () + (+ 6 + (touch f1))))) + 10)))]) + (touch f2))) + +(test 30000 'test9 + (let ([fts (for/list ([i (in-range 0 100)]) + (future (λ () + (build-rand-list '() 300))))]) + (collect-garbage) + (collect-garbage) + (length (append-list-of-lists '() (map touch fts))))) + +(define (sum-to acc limit) + (case limit + [(0) acc] + [else + (sum-to (+ acc limit) (- limit 1))])) + +(test 600030000 'test10 + (let ([f1 (future (λ () (sum-to 0 20000)))] + [f2 (future (λ () (sum-to 0 20000)))] + [f3 (future (λ () (sum-to 0 20000)))]) + (+ (+ (touch f3) (touch f1)) (touch f2)))) + +(test #t 'test11 + (let* ( [f1 (future (λ () (build-rand-list '() 10000)))] + [f2 (future (λ () + (foldl (λ (a b) + (* a b)) + 1 + (touch f1))))] + [f3 (future (λ () (< (touch f2) 1)))]) + (touch f3))) + + +(report-errs) + + + + + + + + + + + + + diff --git a/collects/tests/mzscheme/optimize.ss b/collects/tests/mzscheme/optimize.ss index 7bc16202c1..4647044eb2 100644 --- a/collects/tests/mzscheme/optimize.ss +++ b/collects/tests/mzscheme/optimize.ss @@ -4,7 +4,8 @@ (Section 'optimization) (require scheme/flonum - scheme/fixnum) + scheme/fixnum + compiler/zo-parse) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -564,7 +565,9 @@ [t2 (get-output-bytes s2)]) (or (bytes=? t1 t2) (begin - (printf "~s\n~s\n" t1 t2) + (printf "~s\n~s\n" + (zo-parse (open-input-bytes t1)) + (zo-parse (open-input-bytes t2))) #f ))))) @@ -656,6 +659,17 @@ '((lambda (x) x) 3)) (test-comp '(let ([x 3][y 4]) (+ x y)) '((lambda (x y) (+ x y)) 3 4)) +(test-comp '5 + '((lambda ignored 5) 3 4)) +(test-comp '5 + '(let ([f (lambda ignored 5)]) + (f 3 4))) +(test-comp '5 + '(let ([f (lambda (a . ignored) a)]) + (f 5 3 4))) +(test-comp '(let ([x (list 3 4)]) x) + '(let ([f (lambda (a . b) b)]) + (f 5 3 4))) (test-comp '(let ([x 1][y 2]) x) '1) diff --git a/collects/tests/mzscheme/sync.ss b/collects/tests/mzscheme/sync.ss index 1216bdacef..cc416bac7f 100644 --- a/collects/tests/mzscheme/sync.ss +++ b/collects/tests/mzscheme/sync.ss @@ -465,12 +465,20 @@ (define-values (struct:wt make-wt wt? wt-ref wt-set!) (make-struct-type 'wt #f 2 0 #f (list (cons prop:evt 1)) (make-inspector) #f '(1))) -(let ([always-ready (make-wt #f (lambda (self) #t))] - [always-stuck (make-wt 1 2)]) - (test always-ready sync always-ready) - (test always-ready sync/timeout 0 always-ready) - (test #f sync/timeout 0 always-stuck) - (test #f sync/timeout SYNC-SLEEP-DELAY always-stuck)) +(define-values (struct:wt2 make-wt2 wt2? wt2-ref wt2-set!) + (make-struct-type 'wt2 #f 2 0 #f (list (cons prop:evt 1)) + (make-inspector) 0 '(1))) + +(let ([test-wt + (lambda (make-wt) + (let ([always-ready (make-wt (lambda () 10) (lambda (self) #t))] + [always-stuck (make-wt 1 2)]) + (test always-ready sync always-ready) + (test always-ready sync/timeout 0 always-ready) + (test #f sync/timeout 0 always-stuck) + (test #f sync/timeout SYNC-SLEEP-DELAY always-stuck)))]) + (test-wt make-wt) + (test-wt make-wt2)) ;; Check whether something that takes at least SYNC-SLEEP-DELAY ;; seconds in fact takes roughly that much CPU time. We @@ -496,7 +504,7 @@ (equal? "" Section-prefix)) (test busy? (lambda (a ax b c d) (> b c)) 'busy-wait? go took boundary real-took))))) -(define (test-good-waitable wrap-sema) +(define (test-good-waitable wrap-sema make-wt) (let ([sema (make-semaphore)]) (letrec-values ([(sema-ready-part get-sema-result) (wrap-sema sema sema (lambda () sema-ready))] [(sema-ready) (make-wt 1 sema-ready-part)]) @@ -530,13 +538,18 @@ [(wrapped) (make-wt 3 wrapped-part)]) (non-busy-wait (get-wrapped-result) get-wrapped-result)))))) -(test-good-waitable (lambda (x x-result get-self) - (values x (lambda () x-result)))) -(test-good-waitable (lambda (x x-result get-self) - (let ([ws (choice-evt - x - (make-wt 99 (lambda (self) (make-semaphore))))]) - (values ws (lambda () x-result))))) +(map + (lambda (make-wt) + (test-good-waitable (lambda (x x-result get-self) + (values x (lambda () x-result))) + make-wt) + (test-good-waitable (lambda (x x-result get-self) + (let ([ws (choice-evt + x + (make-wt 99 (lambda (self) (make-semaphore))))]) + (values ws (lambda () x-result)))) + make-wt)) + (list make-wt make-wt2)) (check-busy-wait (letrec ([s (make-semaphore)] @@ -592,22 +605,25 @@ (test bad-stuck-port sync bad-stuck-port)) #t))) -(test-stuck-port (make-semaphore 1) semaphore-try-wait? semaphore-post) -(let ([ready? #t]) - (test-stuck-port (make-wt 77 (lambda (self) - (if ready? - #t - (make-semaphore)))) - (lambda (wt) (set! ready? #f)) - (lambda (wt) (set! ready? #t)))) -(let ([s (make-semaphore 1)]) - (test-stuck-port (make-wt 77 s) - (lambda (wt) (semaphore-try-wait? s)) - (lambda (wt) (semaphore-post s)))) -(let ([s (make-semaphore 1)]) - (test-stuck-port (make-wt 177 (lambda (self) s)) - (lambda (wt) (semaphore-try-wait? s)) - (lambda (wt) (semaphore-post s)))) +(map + (lambda (make-wt) + (test-stuck-port (make-semaphore 1) semaphore-try-wait? semaphore-post) + (let ([ready? #t]) + (test-stuck-port (make-wt 77 (lambda (self) + (if ready? + #t + (make-semaphore)))) + (lambda (wt) (set! ready? #f)) + (lambda (wt) (set! ready? #t)))) + (let ([s (make-semaphore 1)]) + (test-stuck-port (make-wt 77 s) + (lambda (wt) (semaphore-try-wait? s)) + (lambda (wt) (semaphore-post s)))) + (let ([s (make-semaphore 1)]) + (test-stuck-port (make-wt 177 (lambda (self) s)) + (lambda (wt) (semaphore-try-wait? s)) + (lambda (wt) (semaphore-post s))))) + (list make-wt make-wt2)) ;; ---------------------------------------- diff --git a/collects/tests/srfi/19/tests.ss b/collects/tests/srfi/19/tests.ss index c12248d6bf..977f9ed70e 100644 --- a/collects/tests/srfi/19/tests.ss +++ b/collects/tests/srfi/19/tests.ss @@ -4,6 +4,7 @@ ;; John Clements -- 2004-08-16 ;; Dave Gurnell (string->date, date->string) -- 2007-09-14 ;; Dave Gurnell (time{=,<,>,<=,>=}?) -- 2009-11-26 +;; John Clements (nanoseconds off by x100) -- 2009-12-15 (require srfi/19/time) @@ -187,10 +188,22 @@ (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)))) + + ;; nanosecnds off by a factor of 100... + (test-case "nanosecond order-of-magnitude" + ;; half a second should be within 1/10th of 10^9 / 2 nanoseconds (currently off by a factor of 100) + (check-within (let ([t (date-nanosecond (current-date))]) + (sleep 0.5) + (abs (- (date-nanosecond (current-date)) t))) + (* 1/2 (expt 10 9)) + (* 1/10 (expt 10 9)))))) ; Helper checks and procedures ----------------- +(define-simple-check (check-within actual expected epsilon) + (< (abs (- actual expected)) epsilon)) + (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)) diff --git a/collects/tests/stepper/automatic-tests.ss b/collects/tests/stepper/automatic-tests.ss index c2c6709cd6..cfb6039499 100644 --- a/collects/tests/stepper/automatic-tests.ss +++ b/collects/tests/stepper/automatic-tests.ss @@ -1,9 +1,11 @@ -(module automatic-tests mzscheme - (require "through-tests.ss" - "test-engine.ss") - - (parameterize ([display-only-errors #t] - [current-output-port (open-output-string)]) - (if (run-all-tests-except '(bad-and bad-cons check-error begin-let-bug prims qq-splice time set! local-set! lazy1 lazy2 lazy3)) - (exit 1) - (exit 0)))) +#lang scheme + +(require "through-tests.ss" + "test-engine.ss") + +(parameterize ([display-only-errors #t] + [current-output-port (open-output-string)] + [current-namespace (make-base-namespace)]) + (if (run-all-tests-except '(bad-and bad-cons check-error begin-let-bug prims qq-splice time set! local-set! lazy1 lazy2 lazy3)) + (exit 0) + (exit 1))) diff --git a/collects/tests/stepper/language-level-model.ss b/collects/tests/stepper/language-level-model.ss index f7983f888e..5a4c84ff57 100644 --- a/collects/tests/stepper/language-level-model.ss +++ b/collects/tests/stepper/language-level-model.ss @@ -32,6 +32,11 @@ (make-ll-model `(lib "lazy.ss" "lazy") `() fake-mz-render-settings #f #f)) +;; unsure about the render-settings, here: +(define dmda-a + (make-ll-model `(lib "DMdA-beginner.ss" "deinprogramm") '() fake-beginner-render-settings #f #t)) + + ;; SUPPORT FOR TESTING A BUNCH OF LANGUAGES AT ONCE: ;; built-in multi-language bundles: diff --git a/collects/tests/stepper/manual-tests.txt b/collects/tests/stepper/manual-tests.txt index b72d6949d7..cde635e56c 100644 --- a/collects/tests/stepper/manual-tests.txt +++ b/collects/tests/stepper/manual-tests.txt @@ -17,3 +17,5 @@ Try programs which print snips (print-convert-test.ss) try programs that contain test cases; make sure that the popups behave sensibly. Try jumping to the end on a program with an error. +** jumping to end when already at end doesn't behave properly ("no step + matching that criterion") diff --git a/collects/tests/stepper/test-engine.ss b/collects/tests/stepper/test-engine.ss index fee8189a79..ac77a32b55 100644 --- a/collects/tests/stepper/test-engine.ss +++ b/collects/tests/stepper/test-engine.ss @@ -110,6 +110,8 @@ )) + + ;; test-sequence/many : model-or-models/c string? steps? -> (void) ;; run a given test through a bunch of language models (or just one). @@ -167,7 +169,6 @@ (show-result result error-box) (car all-steps))) (set! all-steps (cdr all-steps)))))] - [dc1 (display (expanded-thunk))] [iter-caller (lambda (init iter) (init) @@ -186,8 +187,10 @@ ;; back to us by calling the followup-thunk. (define (call-iter-on-each stx-thunk iter) (let* ([next (stx-thunk)] - [followup-thunk (if (eof-object? next) void (lambda () (call-iter-on-each stx-thunk iter)))]) - (iter next followup-thunk))) + [followup-thunk (if (eof-object? next) void (lambda () (call-iter-on-each stx-thunk iter)))] + [expanded (expand next)]) + ;;(printf "~v\n" expanded) + (iter expanded followup-thunk))) (define (warn error-box who fmt . args) @@ -275,3 +278,6 @@ (lambda () (expand-teaching-program p2 read-syntax namespace-spec teachpack-specs #f module-id enable-testing?))]) (display (expanded-thunk)) (test-sequence/core render-settings show-lambdas-as-lambdas? expanded-thunk '() (box #f)))]) + + + diff --git a/collects/tests/stepper/through-tests.ss b/collects/tests/stepper/through-tests.ss index 1a02656461..b841de6745 100755 --- a/collects/tests/stepper/through-tests.ss +++ b/collects/tests/stepper/through-tests.ss @@ -13,6 +13,7 @@ ) + (provide run-test run-tests run-all-tests run-all-tests-except) (define list-of-tests null) @@ -1130,6 +1131,21 @@ (9 (check-error (+ (hilite 7) (rest empty)) "bogus"))) (before-after (9 false (check-expect (hilite (+ 3 1)) 4)) (9 false (check-expect (hilite 4) 4))))) + + ;;;;;;;;;;;; + ;; + ;; DMdA TESTS + ;; + ;;;;;;;;;;; + + (t1 'dmda-certificate-bug + m:dmda-a + "(: apply-nim-move (integer? -> integer?)) + (define apply-nim-move + (lambda (s) + (if s s s)))" + '()) + ; ;;;;;;;;;;;;; ; ;; @@ -1253,7 +1269,6 @@ ((hilite true))) (finished-stepping))) - ;;;;;;;;;;;;; ;; ;; Set! @@ -1442,7 +1457,11 @@ #;[show-all-steps #t]) #;(run-tests '(check-expect forward-ref check-within check-within-bad check-error check-error-bad)) #;(run-tests '(teachpack-universe)) - #;(run-tests '(check-expect check-within)) + #;(run-tests '(simple-if)) (run-all-tests))) + + + + \ No newline at end of file diff --git a/collects/typed-scheme/private/base-special-env.ss b/collects/typed-scheme/private/base-special-env.ss index 2d430d8b57..539bd140cf 100644 --- a/collects/typed-scheme/private/base-special-env.ss +++ b/collects/typed-scheme/private/base-special-env.ss @@ -12,13 +12,14 @@ string-constants/string-constant ;(prefix-in ce: test-engine/scheme-tests) (for-syntax - scheme/base syntax/parse + scheme/base syntax/parse mzlib/etc (utils tc-utils) (env init-envs) (except-in (rep filter-rep object-rep type-rep) make-arr) (types convenience union) (only-in (types convenience) [make-arr* make-arr]) - (typecheck tc-structs))) + (typecheck tc-structs)) + (for-meta 2 scheme/base syntax/parse)) (define-for-syntax (initialize-others) @@ -78,11 +79,12 @@ (-> (-lst a) (-val '()) (-lst a)) (-> (-lst a) (-lst b) (-lst (*Un a b))))) ;; make-sequence - [(syntax-parse (local-expand #'(for ([x '()]) x) 'expression #f) - #:context #'make-sequence - #:literals (let-values quote) - [(let-values ([_ (m-s '(_) '())]) . _) - #'m-s]) + [(begin-lifted + (syntax-parse (local-expand #'(for ([x '()]) x) 'expression #f) + #:context #'make-sequence + #:literals (let-values quote) + [(let-values ([_ (m-s '(_) '())]) . _) + #'m-s])) (-poly (a) (let ([seq-vals (lambda ([a a]) diff --git a/collects/typed-scheme/typecheck/check-subforms-unit.ss b/collects/typed-scheme/typecheck/check-subforms-unit.ss index ea97a7f1fd..037822e2ee 100644 --- a/collects/typed-scheme/typecheck/check-subforms-unit.ss +++ b/collects/typed-scheme/typecheck/check-subforms-unit.ss @@ -2,6 +2,7 @@ (require "../utils/utils.ss" syntax/kerncase + syntax/parse scheme/match "signatures.ss" "tc-metafunctions.ss" (types utils convenience union subtype) @@ -18,33 +19,40 @@ (define body-ty #f) (define (get-result-ty t) (match t - [(Function: (list (arr: _ (Values: (list (Result: rngs _ _))) #f _ '()) ...)) (apply Un rngs)] - [_ (tc-error "Internal error in get-result-ty: not a function type: ~n~a" t)])) + [(Function: + (list + (arr: _ + (Values: (list (Result: rngs _ _) ...)) + _ _ (list (Keyword: _ _ #t) ...)))) + (apply Un rngs)] + [_ (int-err "Internal error in get-result-ty: not a function type: ~n~a" t)])) (let loop ([form form]) (parameterize ([current-orig-stx form]) - (kernel-syntax-case* form #f (#%app) + (syntax-parse form [stx ;; if this needs to be checked - (syntax-property form 'typechecker:with-type) + #:when (syntax-property form 'typechecker:with-type) ;; the form should be already ascribed the relevant type - (void - (tc-expr form))] + (tc-expr form)] [stx - ;; this is a hander function - (syntax-property form 'typechecker:exn-handler) - (let ([t (tc-expr/t form)]) - (unless (subtype t (-> (Un) Univ)) - (tc-error "Exception handler must be a single-argument function, got ~n~a")) - (set! handler-tys (cons (get-result-ty t) handler-tys)))] + ;; this is a handler function + #:when (syntax-property form 'typechecker:exn-handler) + (let ([t (tc-expr form)]) + (match t + [(tc-result1: + (and t + (Function: (list (arr: (list _) _ _ _ (list (Keyword: _ _ #f) ...)) ...)))) + (set! handler-tys (cons (get-result-ty t) handler-tys))] + [(tc-results: t) + (tc-error "Exception handler must be a single-argument function, got ~n~a" t)]))] [stx ;; this is the body of the with-handlers - (syntax-property form 'typechecker:exn-body) - (let ([t (tc-expr/t form)]) - (set! body-ty t))] + #:when (syntax-property form 'typechecker:exn-body) + (match-let ([(tc-results: ts) (tc-expr form)]) + (set! body-ty (-values ts)))] [(a . b) - (begin - (loop #'a) - (loop #'b))] + (loop #'a) + (loop #'b)] [_ (void)]))) (ret (apply Un body-ty handler-tys))) diff --git a/collects/typed-scheme/typecheck/internal-forms.ss b/collects/typed-scheme/typecheck/internal-forms.ss index a0ce6e9cb0..5c5b6387f1 100644 --- a/collects/typed-scheme/typecheck/internal-forms.ss +++ b/collects/typed-scheme/typecheck/internal-forms.ss @@ -1,16 +1,21 @@ #lang scheme/base -(require (for-syntax scheme/base)) +(require (for-syntax scheme/base) + syntax/parse) -(define-syntax-rule (internal-forms nms ...) +(define-syntax-rule (internal-forms set-name nms ...) (begin - (provide nms ...) + (provide nms ... set-name) + (define-literal-set set-name (nms ...)) (define-syntax (nms stx) (raise-syntax-error 'typecheck "Internal typechecker form used out of context" stx)) ...)) -(internal-forms require/typed-internal define-type-alias-internal - define-typed-struct-internal - define-typed-struct/exec-internal - assert-predicate-internal - declare-refinement-internal - :-internal) +(internal-forms internal-literals + require/typed-internal + define-type-alias-internal + define-type-internal + define-typed-struct-internal + define-typed-struct/exec-internal + assert-predicate-internal + declare-refinement-internal + :-internal) diff --git a/collects/typed-scheme/typecheck/tc-structs.ss b/collects/typed-scheme/typecheck/tc-structs.ss index 99fd72e6f0..634d1dd950 100644 --- a/collects/typed-scheme/typecheck/tc-structs.ss +++ b/collects/typed-scheme/typecheck/tc-structs.ss @@ -90,6 +90,7 @@ #:mutable [setters? #f] #:proc-ty [proc-ty #f] #:maker [maker* #f] + #:predicate [pred* #f] #:constructor-return [cret #f] #:poly? [poly? #f] #:type-only [type-only #f]) @@ -107,6 +108,7 @@ #:type-wrapper type-wrapper #:pred-wrapper pred-wrapper #:maker (or maker* maker) + #:predicate (or pred* pred) #:constructor-return cret)))) ;; generate names, and register the approriate types give field types and structure type @@ -117,6 +119,7 @@ #:type-wrapper [type-wrapper values] #:pred-wrapper [pred-wrapper values] #:maker [maker* #f] + #:predicate [pred* #f] #:constructor-return [cret #f]) ;; create the approriate names that define-struct will bind (define-values (maker pred getters setters) (struct-names nm flds setters?)) @@ -127,7 +130,7 @@ (append (list (cons (or maker* maker) (wrapper (->* external-fld-types (if cret cret name)))) - (cons pred + (cons (or pred* pred) (make-pred-ty (pred-wrapper name)))) (for/list ([g (in-list getters)] [t (in-list external-fld-types/no-parent)] [i (in-naturals)]) (let ([func (if setters? @@ -185,6 +188,7 @@ ;; tc/struct : (U identifier (list identifier identifier)) Listof[identifier] Listof[syntax] -> void (define (tc/struct nm/par flds tys [proc-ty #f] #:maker [maker #f] #:constructor-return [cret #f] #:mutable [mutable #f] + #:predicate [pred #f] #:type-only [type-only #f]) ;; get the parent info and create some types and type variables (define-values (nm parent-name parent name name-tvar) (parse-parent nm/par)) @@ -200,6 +204,7 @@ ;; procedure #:proc-ty proc-ty-parsed #:maker maker + #:predicate pred #:constructor-return (and cret (parse-type cret)) #:mutable mutable #:type-only type-only)) diff --git a/collects/typed-scheme/typecheck/tc-toplevel.ss b/collects/typed-scheme/typecheck/tc-toplevel.ss index 9919da85d4..fac22e91ea 100644 --- a/collects/typed-scheme/typecheck/tc-toplevel.ss +++ b/collects/typed-scheme/typecheck/tc-toplevel.ss @@ -3,11 +3,13 @@ (require (rename-in "../utils/utils.ss" [infer r:infer])) (require syntax/kerncase - unstable/list unstable/syntax + unstable/list unstable/syntax syntax/parse mzlib/etc scheme/match "signatures.ss" "tc-structs.ss" + ;; to appease syntax-parse + "internal-forms.ss" (rep type-rep) (types utils convenience) (private parse-type type-annotation type-contract) @@ -30,13 +32,17 @@ ;; first, find the mutated variables: (find-mutated-vars form) (parameterize ([current-orig-stx form]) - (kernel-syntax-case* form #f (define-type-alias-internal define-typed-struct-internal define-type-internal - define-typed-struct/exec-internal :-internal assert-predicate-internal - require/typed-internal values) + (syntax-parse form + #:literals (values define-type-alias-internal define-typed-struct-internal define-type-internal + define-typed-struct/exec-internal :-internal assert-predicate-internal + require/typed-internal declare-refinement-internal + define-values quote-syntax #%plain-app begin) + ;#:literal-sets (kernel-literals) + ;; forms that are handled in other ways [stx - (or (syntax-property form 'typechecker:ignore) - (syntax-property form 'typechecker:ignore-some)) + #:when (or (syntax-property form 'typechecker:ignore) + (syntax-property form 'typechecker:ignore-some)) (list)] ;; type aliases have already been handled by an earlier pass @@ -73,9 +79,16 @@ (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)))] [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) #:mutable)) (#%plain-app values))) (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:mutable #t)] - [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) #:maker m #:constructor-return t)) + [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) + #:maker m #:constructor-return t #:predicate p)) (#%plain-app values))) - (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:maker #'m #:constructor-return #'t)] + (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) + #:maker #'m #:constructor-return #'t #:predicate #'p)] + [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) + #:maker m #:constructor-return t)) + (#%plain-app values))) + (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) + #:maker #'m #:constructor-return #'t)] [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) #:type-only)) (#%plain-app values))) (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:type-only #t)] @@ -92,8 +105,7 @@ (register-type #'pred (make-pred-ty (parse-type #'ty)))] ;; top-level type annotation - [(define-values () (begin (quote-syntax (:-internal id ty)) (#%plain-app values))) - (identifier? #'id) + [(define-values () (begin (quote-syntax (:-internal id:identifier ty)) (#%plain-app values))) (register-type/undefined #'id (parse-type #'ty))] @@ -129,8 +141,7 @@ (apply append (filter list? (map tc-toplevel/pass1 (syntax->list #'rest))))] ;; define-syntaxes just get noted - [(define-syntaxes (var ...) . rest) - (andmap identifier? (syntax->list #'(var ...))) + [(define-syntaxes (var:id ...) . rest) (map make-def-stx-binding (syntax->list #'(var ...)))] ;; otherwise, do nothing in this pass diff --git a/collects/typed-scheme/utils/syntax-traversal.ss b/collects/typed-scheme/utils/syntax-traversal.ss index cfdaf4178f..e56836e9a7 100644 --- a/collects/typed-scheme/utils/syntax-traversal.ss +++ b/collects/typed-scheme/utils/syntax-traversal.ss @@ -45,9 +45,7 @@ ;; Look for (the outermost) syntax in `orig' that has the same ;; location as `lookfor' which is coming from the expanded `orig', ;; given in `expanded'. -(define (look-for-in-orig orig expanded lookfor) lookfor) - -#| +(define (look-for-in-orig orig expanded lookfor) (define src (syntax-source orig)) ;(printf "orig : ~a~n" (unwind orig)) ;(printf "expanded : ~a~n" expanded) @@ -73,7 +71,4 @@ enclosing) #;(printf "chose branch two ~a~n" enclosing)))))) -;(trace look-for-in-orig) -|# - diff --git a/collects/typed-scheme/utils/tc-utils.ss b/collects/typed-scheme/utils/tc-utils.ss index ce76d55e58..69c990e80b 100644 --- a/collects/typed-scheme/utils/tc-utils.ss +++ b/collects/typed-scheme/utils/tc-utils.ss @@ -6,7 +6,10 @@ don't depend on any other portion of the system |# (provide (all-defined-out)) -(require "syntax-traversal.ss" syntax/parse (for-syntax scheme/base syntax/parse) scheme/match) +(require "syntax-traversal.ss" + "utils.ss" + syntax/parse (for-syntax scheme/base syntax/parse) scheme/match + (for-syntax unstable/syntax)) ;; a parameter representing the original location of the syntax being currently checked (define current-orig-stx (make-parameter #'here)) @@ -126,11 +129,14 @@ don't depend on any other portion of the system (define-struct (exn:fail:tc exn:fail) ()) ;; raise an internal error - typechecker bug! -(define (int-err msg . args) - (raise (make-exn:fail:tc (string-append "Internal Typechecker Error: " - (apply format msg args) - (format "\nwhile typechecking\n~a" (syntax->datum (current-orig-stx)))) - (current-continuation-marks)))) +(define (int-err msg . args) + (parameterize ([custom-printer #t]) + (raise (make-exn:fail:tc (string-append "Internal Typechecker Error: " + (apply format msg args) + (format "\nwhile typechecking\n~aoriginally\n~a" + (syntax->datum (current-orig-stx)) + (syntax->datum (locate-stx (current-orig-stx))))) + (current-continuation-marks))))) (define-syntax (nyi stx) (syntax-case stx () @@ -155,17 +161,8 @@ don't depend on any other portion of the system #:attributes (ty id) (pattern [nm:identifier ty] #:with id #'#'nm) - (pattern [e:expr ty extra-mods ...] - #:with id #'(let ([new-ns - (let* ([ns (make-empty-namespace)]) - (namespace-attach-module (current-namespace) - 'scheme/base - ns) - ns)]) - (parameterize ([current-namespace new-ns]) - (namespace-require 'scheme/base) - (namespace-require 'extra-mods) ... - e)))) + (pattern [e:expr ty] + #:with id #'e)) (syntax-parse stx [(_ e:spec ...) #'(list (list e.id e.ty) ...)])) diff --git a/collects/web-server/lang/closure.ss b/collects/web-server/lang/closure.ss index a2346d6550..2a030cb874 100644 --- a/collects/web-server/lang/closure.ss +++ b/collects/web-server/lang/closure.ss @@ -78,9 +78,12 @@ ; prop-vals: (list (cons prop:serializable #,CLOSURE:serialize-info-id) (cons prop:procedure - (#%plain-lambda (clsr . args) - (let-values ([#,fvars ((CLOSURE-ref clsr 0))]) - (apply #,stx args))))) + (make-keyword-procedure + (lambda (kws kw-vals clsr . rst) + (let-values ([#,fvars ((CLOSURE-ref clsr 0))]) + (keyword-apply #,stx + kws kw-vals + rst)))))) #f ; inspector diff --git a/doc/release-notes/drscheme/HISTORY.txt b/doc/release-notes/drscheme/HISTORY.txt index 247e2b7461..070dbe5653 100644 --- a/doc/release-notes/drscheme/HISTORY.txt +++ b/doc/release-notes/drscheme/HISTORY.txt @@ -10,12 +10,14 @@ - overlay, beside, and above now line things up on centers, rather than upper lefts - added scene-related funtions (place-image, scene+line, etc) + - added support for drawing with various kinds of pens ------------------------------ Version 4.2.3 ------------------------------ . minor bug fixes + . added first draft of the 2htdp/image library ------------------------------ Version 4.2.2 diff --git a/doc/release-notes/mred/HISTORY.txt b/doc/release-notes/mred/HISTORY.txt index 4675ac45d7..0a1e5ca65f 100644 --- a/doc/release-notes/mred/HISTORY.txt +++ b/doc/release-notes/mred/HISTORY.txt @@ -1,3 +1,16 @@ +Version 4.2.4.1 + +Changed radio-box% to allow #f as a selection so that no buttons are + selected + +---------------------------------------------------------------------- + +Version 4.2.4, January 2010 + +Minor bug fixes + +---------------------------------------------------------------------- + Version 4.2.3, November 2009 Minor bug fixes diff --git a/doc/release-notes/mzscheme/HISTORY.txt b/doc/release-notes/mzscheme/HISTORY.txt index dbd1aa21cb..6c5c211139 100644 --- a/doc/release-notes/mzscheme/HISTORY.txt +++ b/doc/release-notes/mzscheme/HISTORY.txt @@ -1,26 +1,11 @@ -Version 4.2.3.12 -Added module->imports and module->exports - -Version 4.2.3.10 -Added more fl and fx operations - -Version 4.2.3.8 -Added scheme/flonum; moved flvector operations to scheme/flonum - -Version 4.2.3.6 +Version 4.2.4, January 2010 +Added scheme/flonum and scheme/fixnum +Extended scheme/unsafe/ops Changed JIT to support unboxed local binding of known-flonum arguments to unsafe-fl functions -Added unsafe-flsqrt - -Version 4.2.3.5 -Added #:save-errno option for foreign-function types - -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 +Added #:save-errno option for foreign-function types +Added module->imports and module->exports Version 4.2.3, November 2009 Changed _pointer (in scheme/foreign) to mean a pointer that does not diff --git a/doc/release-notes/redex/HISTORY.txt b/doc/release-notes/redex/HISTORY.txt index db4fa58971..8ade9006d4 100644 --- a/doc/release-notes/redex/HISTORY.txt +++ b/doc/release-notes/redex/HISTORY.txt @@ -1,3 +1,9 @@ + * Renamed the #:attempts keyword #:attempt-num in the `generate-term' form + +v4.2.4 + + * minor bug fixes + v4.2.3 * added support for collecting metafunction coverage, using the diff --git a/doc/release-notes/stepper/HISTORY.txt b/doc/release-notes/stepper/HISTORY.txt index 670fa93772..85223adce9 100644 --- a/doc/release-notes/stepper/HISTORY.txt +++ b/doc/release-notes/stepper/HISTORY.txt @@ -1,6 +1,10 @@ Stepper ------- +Changes for v4.2.4: + +Bug fixes. + Changes for v4.2.3: Bug fixes, show first step as soon as it appears. diff --git a/doc/release-notes/teachpack/HISTORY.txt b/doc/release-notes/teachpack/HISTORY.txt index ae902a89c9..438c8629c4 100644 --- a/doc/release-notes/teachpack/HISTORY.txt +++ b/doc/release-notes/teachpack/HISTORY.txt @@ -1,3 +1,13 @@ +------------------------------------------------------------------------ +Version 4.2.4 [Thu Jan 28 12:02:01 EST 2010] + +* separated 2htdp/universe from htdp/image +* 2htdp/universe contains some stupid hacks to improve performance + -- to be changed with Matthew's advice +* error modified +* added a bunch of primitives for JPR +* fixed some other bugs + ------------------------------------------------------------------------ Version 4.2.3 [Sun Nov 22 19:25:01 EST 2009] diff --git a/src/README b/src/README index 1e36c25615..af41c47d41 100644 --- a/src/README +++ b/src/README @@ -385,21 +385,14 @@ mzscheme/sconfig.h to provide a platform-specific compilation information. As dsitributed, mzscheme/sconfig.h contains configurations for the following platforms: - Windows - Mac OS X - Linux (x86, PPC, 68k, Alpha) - Cygwin + Windows (x86) + Mac OS X (PPC, x86, x86_64) + Linux (x86, x86_64, PPC, 68k) + Cygwin (x86) Solaris (x86, Sparc) - SunOS4 (Sparc) - IBM AIX (RS6000) - SGI IRIX (Mips) - DEC Ultrix - HP/UX - FreeBSD - OpenBSD - NetBSD - OSF1 (Alpha) - SCO Unix (x86) + FreeBSD (x86) + OpenBSD (x86) + NetBSD (x86) If your platfrom is not supported by the Boehm garbage collector (distributed with PLT source), provide the `--enable-sgc' flag to diff --git a/src/configure b/src/configure index b0acdacae6..a1adb8948b 100755 --- a/src/configure +++ b/src/configure @@ -706,7 +706,7 @@ FRAMEWORK_REL_INSTALL FRAMEWORK_PREFIX INSTALL_ORIG_TREE EXE_SUFFIX -PLACE_CGC_FLAGS +MZRT_CGC_FLAGS LIBATOM MREDLINKER LIBSFX @@ -2316,7 +2316,7 @@ ZLIB_INC='$(ZLIB_INC)' PNG_A='$(PNG_A)' PREFLAGS="$CPPFLAGS" -PLACE_CGC_FLAGS="" +MZRT_CGC_FLAGS="" LIBATOM="LIBATOM_NONE" ar_libtool_no_undefined="" @@ -10712,16 +10712,24 @@ fi if test "${enable_places}" = "yes" ; then PREFLAGS="$PREFLAGS -DMZ_USE_PLACES" - PLACE_CGC_FLAGS="$GC_THREADS_FLAG -DTHREAD_LOCAL_ALLOC" LDFLAGS="$LDFLAGS -pthread" - LIBATOM="LIBATOM_USE" + enable_mzrt=yes fi ############### futures ################### if test "${enable_futures}" = "yes" ; then - PREFLAGS="$PREFLAGS -DFUTURES_ENABLED -DUSE_PTHREAD_INSTEAD_OF_ITIMER" + PREFLAGS="$PREFLAGS -DMZ_USE_FUTURES" + enable_mzrt=yes +fi + +############### OS threads ################### + +if test "${enable_mzrt}" = "yes" ; then + PREFLAGS="$PREFLAGS -DUSE_PTHREAD_INSTEAD_OF_ITIMER" LDFLAGS="$LDFLAGS -pthread" + MZRT_CGC_FLAGS="$GC_THREADS_FLAG -DTHREAD_LOCAL_ALLOC" + LIBATOM="LIBATOM_USE" fi ################ Xrender ################## @@ -12959,7 +12967,7 @@ FRAMEWORK_REL_INSTALL!$FRAMEWORK_REL_INSTALL$ac_delim FRAMEWORK_PREFIX!$FRAMEWORK_PREFIX$ac_delim INSTALL_ORIG_TREE!$INSTALL_ORIG_TREE$ac_delim EXE_SUFFIX!$EXE_SUFFIX$ac_delim -PLACE_CGC_FLAGS!$PLACE_CGC_FLAGS$ac_delim +MZRT_CGC_FLAGS!$MZRT_CGC_FLAGS$ac_delim LIBATOM!$LIBATOM$ac_delim MREDLINKER!$MREDLINKER$ac_delim LIBSFX!$LIBSFX$ac_delim diff --git a/src/mred/mrmain.cxx b/src/mred/mrmain.cxx index 5ee4d8a030..0b4f437157 100644 --- a/src/mred/mrmain.cxx +++ b/src/mred/mrmain.cxx @@ -292,12 +292,14 @@ static int call_main_after_stack(void *data) } int main(int argc, char *argv[]) + XFORM_SKIP_PROC { Main_Args ma; ma.argc = argc; ma.argv = argv; return scheme_main_stack_setup(1, call_main_after_stack, &ma); } + #endif /* **************************************************************** */ diff --git a/src/mred/wxs/range.xci b/src/mred/wxs/range.xci index d9d0807da0..7b8b2d70d7 100644 --- a/src/mred/wxs/range.xci +++ b/src/mred/wxs/range.xci @@ -3,3 +3,6 @@ @MACRO RANGERET[p.rv] = if ((x

          < 0) || (x

          >= THISOBJECT->Number())) { READY_TO_RETURN; return ; } @MACRO RANGE[p] = $$RANGERET[

          .scheme_void] + +@MACRO RANGEXRET[p.rv] = if ((x

          < -1) || (x

          >= THISOBJECT->Number())) { READY_TO_RETURN; return ; } +@MACRO RANGEX[p] = $$RANGEXRET[

          .scheme_void] diff --git a/src/mred/wxs/wxs_chce.cxx b/src/mred/wxs/wxs_chce.cxx index 227a37a41c..519baf1cc6 100644 --- a/src/mred/wxs/wxs_chce.cxx +++ b/src/mred/wxs/wxs_chce.cxx @@ -251,6 +251,7 @@ static l_TYPE l_POINT *l_MAKE_ARRAY(Scheme_Object *l, l_INTTYPE *c, char *who) + class os_wxChoice : public wxChoice { public: Scheme_Object *callback_closure; diff --git a/src/mred/wxs/wxs_lbox.cxx b/src/mred/wxs/wxs_lbox.cxx index 9b407808c6..915aae2844 100644 --- a/src/mred/wxs/wxs_lbox.cxx +++ b/src/mred/wxs/wxs_lbox.cxx @@ -289,6 +289,7 @@ static l_TYPE l_POINT *l_MAKE_ARRAY(Scheme_Object *l, l_INTTYPE *c, char *who) + class os_wxListBox : public wxListBox { public: Scheme_Object *callback_closure; diff --git a/src/mred/wxs/wxs_rado.cxx b/src/mred/wxs/wxs_rado.cxx index 10816ea348..50d6ceb8cc 100644 --- a/src/mred/wxs/wxs_rado.cxx +++ b/src/mred/wxs/wxs_rado.cxx @@ -345,6 +345,7 @@ static l_TYPE l_POINT *l_MAKE_ARRAY(Scheme_Object *l, l_INTTYPE *c, char *who) + class os_wxRadioBox : public wxRadioBox { public: Scheme_Object *callback_closure; @@ -706,7 +707,7 @@ static Scheme_Object *os_wxRadioBoxSetSelection(int n, Scheme_Object *p[]) x0 = WITH_VAR_STACK(objscheme_unbundle_integer(p[POFFSET+0], "set-selection in radio-box%")); - if ((x0 < 0) || (x0 >= THISOBJECT->Number())) { READY_TO_RETURN; return scheme_void; } + if ((x0 < -1) || (x0 >= THISOBJECT->Number())) { READY_TO_RETURN; return scheme_void; } WITH_VAR_STACK(((wxRadioBox *)((Scheme_Class_Object *)p[0])->primdata)->SetSelection(x0)); diff --git a/src/mred/wxs/wxs_rado.xc b/src/mred/wxs/wxs_rado.xc index 3208c8691e..04f1bc90ab 100644 --- a/src/mred/wxs/wxs_rado.xc +++ b/src/mred/wxs/wxs_rado.xc @@ -48,7 +48,7 @@ @ "get-selection" : int GetSelection(); @ "number" : int Number() -@ "set-selection" : void SetSelection(int); : : /RANGE[0] +@ "set-selection" : void SetSelection(int); : : /RANGEX[0] @ "enable" : void Enable(int,bool); : : /RANGE[0] <> single-button @ "enable" : void Enable(bool); <> all-buttons diff --git a/src/mred/wxs/wxs_tabc.cxx b/src/mred/wxs/wxs_tabc.cxx index 497bf18388..7fc3ba40cb 100644 --- a/src/mred/wxs/wxs_tabc.cxx +++ b/src/mred/wxs/wxs_tabc.cxx @@ -274,6 +274,7 @@ static int unbundle_symset_tabStyle(Scheme_Object *v, const char *where) { + class os_wxTabChoice : public wxTabChoice { public: Scheme_Object *callback_closure; diff --git a/src/mzscheme/Makefile.in b/src/mzscheme/Makefile.in index 97d3fbe380..f9d7425895 100644 --- a/src/mzscheme/Makefile.in +++ b/src/mzscheme/Makefile.in @@ -221,8 +221,7 @@ $(collectsdir)/scheme/private/kernstruct.ss: $(srcdir)/src/makeexn $(srcdir)/src/$(CSTARTUPDEST): $(srcdir)/src/startup.ss $(srcdir)/src/schvers.h $(srcdir)/src/schminc.h - ./mzscheme@CGC@ -cqu $(srcdir)/src/sstoinc.ss $(CSTARTUPEXTRA) < $(srcdir)/src/startup.ss > $(srcdir)/src/$(CSTARTUPDEST) - + ./mzscheme@CGC@ -cqu $(srcdir)/src/sstoinc.ss $(CSTARTUPEXTRA) $(srcdir)/src/$(CSTARTUPDEST) < $(srcdir)/src/startup.ss $(srcdir)/src/mzmark.c: $(srcdir)/src/mzmarksrc.c $(srcdir)/src/mkmark.ss mzscheme -cu $(srcdir)/src/mkmark.ss < $(srcdir)/src/mzmarksrc.c > $(srcdir)/src/mzmark.c diff --git a/src/mzscheme/configure.ac b/src/mzscheme/configure.ac index 266010fb79..b2c75c1e32 100644 --- a/src/mzscheme/configure.ac +++ b/src/mzscheme/configure.ac @@ -354,7 +354,7 @@ ZLIB_INC='$(ZLIB_INC)' PNG_A='$(PNG_A)' PREFLAGS="$CPPFLAGS" -PLACE_CGC_FLAGS="" +MZRT_CGC_FLAGS="" LIBATOM="LIBATOM_NONE" ar_libtool_no_undefined="" @@ -1142,16 +1142,24 @@ fi if test "${enable_places}" = "yes" ; then PREFLAGS="$PREFLAGS -DMZ_USE_PLACES" - PLACE_CGC_FLAGS="$GC_THREADS_FLAG -DTHREAD_LOCAL_ALLOC" LDFLAGS="$LDFLAGS -pthread" - LIBATOM="LIBATOM_USE" + enable_mzrt=yes fi ############### futures ################### if test "${enable_futures}" = "yes" ; then - PREFLAGS="$PREFLAGS -DFUTURES_ENABLED -DUSE_PTHREAD_INSTEAD_OF_ITIMER" + PREFLAGS="$PREFLAGS -DMZ_USE_FUTURES" + enable_mzrt=yes +fi + +############### OS threads ################### + +if test "${enable_mzrt}" = "yes" ; then + PREFLAGS="$PREFLAGS -DUSE_PTHREAD_INSTEAD_OF_ITIMER" LDFLAGS="$LDFLAGS -pthread" + MZRT_CGC_FLAGS="$GC_THREADS_FLAG -DTHREAD_LOCAL_ALLOC" + LIBATOM="LIBATOM_USE" fi ################ Xrender ################## @@ -1432,7 +1440,7 @@ AC_SUBST(FRAMEWORK_REL_INSTALL) AC_SUBST(FRAMEWORK_PREFIX) AC_SUBST(INSTALL_ORIG_TREE) AC_SUBST(EXE_SUFFIX) -AC_SUBST(PLACE_CGC_FLAGS) +AC_SUBST(MZRT_CGC_FLAGS) AC_SUBST(LIBATOM) AC_SUBST(MREDLINKER) diff --git a/src/mzscheme/gc/Makefile.in b/src/mzscheme/gc/Makefile.in index 188c530451..f5db01a36b 100644 --- a/src/mzscheme/gc/Makefile.in +++ b/src/mzscheme/gc/Makefile.in @@ -47,7 +47,7 @@ mainsrcdir = @srcdir@/../.. # compiler options; mainly used to allow importing options OPTIONS=@OPTIONS@ @CGCOPTIONS@ -BASEFLAGS= -I$(srcdir)/include -I$(AO_INSTALL_DIR)/src @CFLAGS@ @COMPFLAGS@ @PREFLAGS@ @PLACE_CGC_FLAGS@ +BASEFLAGS= -I$(srcdir)/include -I$(AO_INSTALL_DIR)/src @CFLAGS@ @COMPFLAGS@ @PREFLAGS@ @MZRT_CGC_FLAGS@ CFLAGS= $(BASEFLAGS) @PROFFLAGS@ $(OPTIONS) -DNO_EXECUTE_PERMISSION -DSILENT -DNO_GETENV -DLARGE_CONFIG -DATOMIC_UNCOLLECTABLE -DINITIAL_MARK_STACK_SIZE=8192 # To build the parallel collector on Linux, add to the above: diff --git a/src/mzscheme/gc2/newgc.c b/src/mzscheme/gc2/newgc.c index 17561ff814..32640c0b10 100644 --- a/src/mzscheme/gc2/newgc.c +++ b/src/mzscheme/gc2/newgc.c @@ -2978,7 +2978,7 @@ static void fprintf_debug(NewGC *gc, const char *msg, objhead *info, FILE* file, 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)); + fprintf_buffer(file, ((char *)obj), (info->size * WORD_SIZE) - sizeof(objhead)); break; } } @@ -3309,6 +3309,7 @@ static void clean_up_heap(NewGC *gc) cleanup_vacated_pages(gc); } +#ifdef MZ_USE_PLACES static void unprotect_old_pages(NewGC *gc) { Page_Range *protect_range = gc->protect_range; @@ -3337,6 +3338,8 @@ static void unprotect_old_pages(NewGC *gc) flush_protect_page_ranges(protect_range, 0); } +#endif + static void protect_old_pages(NewGC *gc) { Page_Range *protect_range = gc->protect_range; diff --git a/src/mzscheme/include/scheme.h b/src/mzscheme/include/scheme.h index f1b4e5469c..94b9f03ae3 100644 --- a/src/mzscheme/include/scheme.h +++ b/src/mzscheme/include/scheme.h @@ -147,25 +147,6 @@ typedef jmpbuf jmp_buf[1]; typedef struct FSSpec mzFSSpec; #endif -/* Set up MZ_EXTERN for DLL build */ -#if defined(WINDOWS_DYNAMIC_LOAD) \ - && !defined(LINK_EXTENSIONS_BY_TABLE) \ - && !defined(SCHEME_EMBEDDED_NO_DLL) -# define MZ_DLLIMPORT __declspec(dllimport) -# define MZ_DLLEXPORT __declspec(dllexport) -# ifdef __mzscheme_private__ -# define MZ_DLLSPEC __declspec(dllexport) -# else -# define MZ_DLLSPEC __declspec(dllimport) -# endif -#else -# define MZ_DLLSPEC -# define MZ_DLLIMPORT -# define MZ_DLLEXPORT -#endif - -#define MZ_EXTERN extern MZ_DLLSPEC - #ifndef MZ_DONT_USE_JIT # if defined(MZ_USE_JIT_PPC) || defined(MZ_USE_JIT_I386) || defined(MZ_USE_JIT_X86_64) # define MZ_USE_JIT diff --git a/src/mzscheme/include/schthread.h b/src/mzscheme/include/schthread.h index 5d53e414b8..b21438887c 100644 --- a/src/mzscheme/include/schthread.h +++ b/src/mzscheme/include/schthread.h @@ -19,8 +19,8 @@ #ifndef SCHEME_THREADLOCAL_H #define SCHEME_THREADLOCAL_H -#if defined(MZ_USE_PLACES) || defined(FUTURES_ENABLED) -# define USE_THREAD_LOCAL +#if defined(MZ_USE_PLACES) || defined(MZ_USE_FUTURES) +# define USE_THREAD_LOCAL # if _MSC_VER # define THREAD_LOCAL __declspec(thread) # elif defined(OS_X) || (defined(linux) && defined(MZ_USES_SHARED_LIB)) @@ -35,7 +35,26 @@ # define THREAD_LOCAL /* empty */ #endif -extern void scheme_init_os_thread(); +/* Set up MZ_EXTERN for DLL build */ +#if (defined(__WIN32__) || defined(WIN32) || defined(_WIN32)) \ + && !defined(LINK_EXTENSIONS_BY_TABLE) \ + && !defined(SCHEME_EMBEDDED_NO_DLL) +# define MZ_DLLIMPORT __declspec(dllimport) +# define MZ_DLLEXPORT __declspec(dllexport) +# ifdef __mzscheme_private__ +# define MZ_DLLSPEC __declspec(dllexport) +# else +# define MZ_DLLSPEC __declspec(dllimport) +# endif +#else +# define MZ_DLLSPEC +# define MZ_DLLIMPORT +# define MZ_DLLEXPORT +#endif + +#define MZ_EXTERN extern MZ_DLLSPEC + +MZ_EXTERN void scheme_init_os_thread(); /* **************************************************************** */ /* Declarations that we wish were elsewhere, but are needed here to */ @@ -77,7 +96,7 @@ typedef long objhead; /* **************************************** */ -#if FUTURES_ENABLED +#if MZ_USE_FUTURES # include #endif @@ -193,8 +212,8 @@ typedef struct Thread_Local_Variables { void *jit_future_storage_[2]; struct Scheme_Object **scheme_current_runstack_start_; struct Scheme_Object **scheme_current_runstack_; - MZ_MARK_STACK_TYPE scheme_current_cont_mark_stack_; - MZ_MARK_POS_TYPE scheme_current_cont_mark_pos_; + long scheme_current_cont_mark_stack_; + long scheme_current_cont_mark_pos_; struct Scheme_Custodian *main_custodian_; struct Scheme_Custodian *last_custodian_; struct Scheme_Hash_Table *limited_custodians_; @@ -215,7 +234,6 @@ typedef struct Thread_Local_Variables { struct Scheme_Object *recycle_cell_; struct Scheme_Object *maybe_recycle_cell_; int recycle_cc_count_; - mz_jmp_buf main_init_error_buf_; void *gmp_mem_pool_; unsigned long max_total_allocation_; unsigned long current_total_allocation_; @@ -226,14 +244,14 @@ typedef struct Thread_Local_Variables { int builtin_ref_counter_; int env_uid_counter_; int scheme_overflow_count_; - Scheme_Object *original_pwd_; + struct Scheme_Object *original_pwd_; long scheme_hash_request_count_; long scheme_hash_iteration_count_; - Scheme_Env *initial_modules_env_; + struct Scheme_Env *initial_modules_env_; int num_initial_modules_; - Scheme_Object **initial_modules_; - Scheme_Object *initial_renames_; - Scheme_Bucket_Table *initial_toplevel_; + struct Scheme_Object **initial_modules_; + struct Scheme_Object *initial_renames_; + struct Scheme_Bucket_Table *initial_toplevel_; int generate_lifts_count_; int special_is_ok_; int scheme_force_port_closed_; @@ -253,13 +271,14 @@ typedef struct Thread_Local_Variables { long start_this_gc_time_; long end_this_gc_time_; volatile short delayed_break_ready_; - Scheme_Thread *main_break_target_thread_; + struct Scheme_Thread *main_break_target_thread_; long scheme_code_page_total_; int locale_on_; - const mzchar *current_locale_name_; + void *current_locale_name_ptr_; int gensym_counter_; - Scheme_Object *dummy_input_port_; - Scheme_Object *dummy_output_port_; + struct Scheme_Object *dummy_input_port_; + struct Scheme_Object *dummy_output_port_; + struct Scheme_Bucket_Table *place_local_modpath_table_; /*KPLAKE1*/ } Thread_Local_Variables; @@ -460,7 +479,6 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL; #define recycle_cell XOA (scheme_get_thread_local_variables()->recycle_cell_) #define maybe_recycle_cell XOA (scheme_get_thread_local_variables()->maybe_recycle_cell_) #define recycle_cc_count XOA (scheme_get_thread_local_variables()->recycle_cc_count_) -#define main_init_error_buf XOA (scheme_get_thread_local_variables()->main_init_error_buf_) #define gmp_mem_pool XOA (scheme_get_thread_local_variables()->gmp_mem_pool_) #define max_total_allocation XOA (scheme_get_thread_local_variables()->max_total_allocation_) #define current_total_allocation XOA (scheme_get_thread_local_variables()->current_total_allocation_) @@ -501,10 +519,11 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL; #define main_break_target_thread XOA (scheme_get_thread_local_variables()->main_break_target_thread_) #define scheme_code_page_total XOA (scheme_get_thread_local_variables()->scheme_code_page_total_) #define locale_on XOA (scheme_get_thread_local_variables()->locale_on_) -#define current_locale_name XOA (scheme_get_thread_local_variables()->current_locale_name_) +#define current_locale_name_ptr XOA (scheme_get_thread_local_variables()->current_locale_name_ptr_) #define gensym_counter XOA (scheme_get_thread_local_variables()->gensym_counter_) #define dummy_input_port XOA (scheme_get_thread_local_variables()->dummy_input_port_) #define dummy_output_port XOA (scheme_get_thread_local_variables()->dummy_output_port_) +#define place_local_modpath_table XOA (scheme_get_thread_local_variables()->place_local_modpath_table_) /*KPLAKE2*/ /* **************************************** */ diff --git a/src/mzscheme/src/Makefile.in b/src/mzscheme/src/Makefile.in index 5b6dce72e8..f745e33c2c 100644 --- a/src/mzscheme/src/Makefile.in +++ b/src/mzscheme/src/Makefile.in @@ -272,7 +272,7 @@ fun.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/../src/stypes.h $(srcdir)/mzmark.c $(srcdir)/schmap.inc \ $(srcdir)/future.h future.@LTO@: $(srcdir)/schpriv.h $(srcdir)/future.h $(SCONFIG) $(srcdir)/../include/scheme.h \ - $(srcdir)/../src/stypes.h $(srcdir)/mzmark.c \ + $(srcdir)/../src/stypes.h $(srcdir)/mzmark.c $(srcdir)/mzrt.c \ $(srcdir)/jit_ts_future_glue.c $(srcdir)/jit_ts_runtime_glue.c $(srcdir)/jit_ts_protos.h hash.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/../src/stypes.h $(srcdir)/mzmark.c diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index 8bfe025c08..60e7d2c208 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -32,7 +32,7 @@ #include "schminc.h" #include "schmach.h" #include "schexpobs.h" -#ifdef FUTURES_ENABLED +#ifdef MZ_USE_FUTURES # include "future.h" #endif @@ -508,13 +508,15 @@ static Scheme_Env *place_instance_init(void *stack_base, int initial_main_os_thr #endif scheme_init_error_config(); +/* BEGIN PRIMITIVE MODULES */ scheme_init_memtrace(env); #ifndef NO_TCP_SUPPORT scheme_init_network(env); #endif - scheme_init_parameterization(env); + scheme_init_paramz(env); scheme_init_expand_observe(env); scheme_init_place(env); +/* END PRIMITIVE MODULES */ #if defined(MZ_USE_PLACES) scheme_jit_fill_threadlocal_table(); #endif @@ -631,6 +633,7 @@ static void make_kernel_env(void) #ifndef NO_REGEXP_UTILS MZTIMEIT(regexp, scheme_regexp_initialize(env)); #endif + scheme_init_parameterization(); MARK_START_TIME(); diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 71f314cc91..798c101ede 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -143,7 +143,7 @@ #ifdef MACOS_STACK_LIMIT #include #endif -#ifdef FUTURES_ENABLED +#ifdef MZ_USE_FUTURES # include "future.h" #endif @@ -2435,10 +2435,12 @@ static Scheme_Object *apply_inlined(Scheme_Object *p, Scheme_Closure_Data *data, { Scheme_Let_Header *lh; Scheme_Compiled_Let_Value *lv, *prev = NULL; - int i; + int i, expected; int *flags, flag; - if (!argc) { + expected = data->num_params; + + if (!expected) { info = scheme_optimize_info_add_frame(info, 0, 0, 0); info->inline_fuel >>= 1; p = scheme_optimize_expr(p, info, context); @@ -2450,16 +2452,37 @@ static Scheme_Object *apply_inlined(Scheme_Object *p, Scheme_Closure_Data *data, lh = MALLOC_ONE_TAGGED(Scheme_Let_Header); lh->iso.so.type = scheme_compiled_let_void_type; - lh->count = argc; - lh->num_clauses = argc; + lh->count = expected; + lh->num_clauses = expected; - for (i = 0; i < argc; i++) { + for (i = 0; i < expected; i++) { lv = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value); lv->so.type = scheme_compiled_let_value_type; lv->count = 1; lv->position = i; - if (app) + if ((i == expected - 1) + && (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST)) { + int j; + Scheme_Object *l = scheme_null, *val; + + for (j = argc; j-- > i; ) { + if (app) + val = app->args[j + 1]; + else if (app3) + val = (j ? app3->rand2 : app3->rand1); + else if (app2) + val = app2->rand; + else + val = scheme_false; + + l = cons(val, l); + } + l = cons(scheme_list_proc, l); + val = make_application(l); + + lv->value = val; + } else if (app) lv->value = app->args[i + 1]; else if (app3) lv->value = (i ? app3->rand2 : app3->rand1); @@ -2536,20 +2559,22 @@ Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int a Scheme_Closure_Data *data = (Scheme_Closure_Data *)le; int sz; - if (!app && !app2 && !app3) { + if (!app && !app2 && !app3) return le; - } *_flags = SCHEME_CLOSURE_DATA_FLAGS(data); - - if ((data->num_params == argc) || (!app && !app2 && !app3)) { + + if ((data->num_params == argc) + || ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) + && (argc + 1 >= data->num_params)) + || (!app && !app2 && !app3)) { int threshold; sz = scheme_closure_body_size(data, 1, info); threshold = info->inline_fuel * (2 + argc); if ((sz >= 0) && (single_use || (sz <= threshold))) { - le = scheme_optimize_clone(0, data->code, info, offset, argc); + le = scheme_optimize_clone(0, data->code, info, offset, data->num_params); if (le) { LOG_INLINE(fprintf(stderr, "Inline %d %d %s\n", sz, single_use, data->name ? scheme_write_to_string(data->name, NULL) : "???")); return apply_inlined(le, data, info, argc, app, app2, app3, context); @@ -2562,11 +2587,8 @@ Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int a info->inline_fuel, info->use_psize)); } } else { - if (!(SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) - || (argc + 1 < data->num_params)) { - /* Issue warning below */ - bad_app = (Scheme_Object *)data; - } + /* Issue warning below */ + bad_app = (Scheme_Object *)data; } } @@ -3725,6 +3747,8 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int } } + t = scheme_optimize_expr(t, info, OPT_CONTEXT_BOOLEAN); + /* Try optimize: (if (not x) y z) => (if x z y) */ while (1) { if (SAME_TYPE(SCHEME_TYPE(t), scheme_application2_type)) { @@ -3742,8 +3766,6 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int break; } - t = scheme_optimize_expr(t, info, OPT_CONTEXT_BOOLEAN); - info->vclock += 1; /* model branch as clock increment */ if (SCHEME_TYPE(t) > _scheme_compiled_values_types_) { @@ -6726,7 +6748,7 @@ compile_expand_app(Scheme_Object *forms, Scheme_Comp_Env *env, name = scheme_check_immediate_macro(name, env, rec, drec, 0, &gval, NULL, NULL); - /* look for ((lambda (x) ...) ...); */ + /* look for ((lambda (x ...) ....) ....) or ((lambda x ....) ....) */ if (SAME_OBJ(gval, scheme_lambda_syntax)) { Scheme_Object *argsnbody; @@ -6740,15 +6762,15 @@ compile_expand_app(Scheme_Object *forms, Scheme_Comp_Env *env, if (SCHEME_STX_PAIRP(body)) { int pl; pl = scheme_stx_proper_list_length(args); - if (pl >= 0) { + if ((pl >= 0) || SCHEME_STX_SYMBOLP(args)) { Scheme_Object *bindings = scheme_null, *last = NULL; Scheme_Object *rest; int al; - + rest = SCHEME_STX_CDR(form); al = scheme_stx_proper_list_length(rest); - if (al == pl) { + if ((pl < 0) || (al == pl)) { DupCheckRecord r; scheme_begin_dup_symbol_check(&r, env); @@ -6756,7 +6778,10 @@ compile_expand_app(Scheme_Object *forms, Scheme_Comp_Env *env, while (!SCHEME_STX_NULLP(args)) { Scheme_Object *v, *n; - n = SCHEME_STX_CAR(args); + if (pl < 0) + n = args; + else + n = SCHEME_STX_CAR(args); scheme_check_identifier("lambda", n, NULL, env, name); /* If we don't check here, the error is in terms of `let': */ @@ -6765,7 +6790,12 @@ compile_expand_app(Scheme_Object *forms, Scheme_Comp_Env *env, /* Propagate certifications to bound id: */ n = scheme_stx_cert(n, NULL, NULL, name, NULL, 1); - v = SCHEME_STX_CAR(rest); + if (pl < 0) { + v = scheme_intern_symbol("list"); + v = scheme_datum_to_syntax(v, scheme_false, scheme_sys_wraps(env), 0, 0); + v = cons(v, rest); + } else + v = SCHEME_STX_CAR(rest); v = cons(cons(cons(n, scheme_null), cons(v, scheme_null)), scheme_null); if (last) SCHEME_CDR(last) = v; @@ -6773,8 +6803,13 @@ compile_expand_app(Scheme_Object *forms, Scheme_Comp_Env *env, bindings = v; last = v; - args = SCHEME_STX_CDR(args); - rest = SCHEME_STX_CDR(rest); + if (pl < 0) { + /* rator is (lambda rest-x ....) */ + break; + } else { + args = SCHEME_STX_CDR(args); + rest = SCHEME_STX_CDR(rest); + } } body = scheme_datum_to_syntax(icons(begin_symbol, body), form, @@ -6994,7 +7029,7 @@ static Scheme_Object *check_top(const char *when, Scheme_Object *form, Scheme_Co if (bad || !scheme_lookup_in_table(env->genv->toplevel, (const char *)SCHEME_STX_SYM(c))) { GC_CAN_IGNORE const char *reason; if (env->genv->phase == 1) { - reason = "unbound identifier in module (transformer environment)"; + reason = "unbound identifier in module (in phase 1, transformer environment)"; /* Check in the run-time environment */ if (scheme_lookup_in_table(env->genv->template_env->toplevel, (const char *)SCHEME_STX_SYM(c))) { reason = ("unbound identifier in module (in the transformer environment, which does" @@ -7004,9 +7039,11 @@ static Scheme_Object *check_top(const char *when, Scheme_Object *form, Scheme_Co reason = ("unbound identifier in module (in the transformer environment, which does" " not include the macro definition that is visible to run-time expressions)"); } - } else + } else if (env->genv->phase == 0) reason = "unbound identifier in module"; - scheme_wrong_syntax(when, NULL, c, reason); + else + reason = "unbound identifier in module (in phase %d)"; + scheme_wrong_syntax(when, NULL, c, reason, env->genv->phase); } } } @@ -9723,7 +9760,7 @@ static void *eval_k(void) v = scheme_eval_clone(v); rp = scheme_prefix_eval_clone(top->prefix); - save_runstack = scheme_push_prefix(env, top->prefix, NULL, NULL, 0, env->phase); + save_runstack = scheme_push_prefix(env, top->prefix, NULL, NULL, 0, env->phase, NULL); if (as_tail) { /* Cons up a closure to capture the prefix */ @@ -11031,7 +11068,8 @@ int scheme_prefix_depth(Resolve_Prefix *rp) Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp, Scheme_Object *src_modidx, Scheme_Object *now_modidx, - int src_phase, int now_phase) + int src_phase, int now_phase, + Scheme_Env *dummy_env) { Scheme_Object **rs_save, **rs, *v, **a; int i, j; @@ -11056,8 +11094,8 @@ Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp, for (i = 0; i < rp->num_toplevels; i++) { v = rp->toplevels[i]; - if (genv) - v = link_toplevel(rp->toplevels, i, genv, src_modidx, now_modidx); + if (genv || SCHEME_FALSEP(v)) + v = link_toplevel(rp->toplevels, i, genv ? genv : dummy_env, src_modidx, now_modidx); a[i] = v; } diff --git a/src/mzscheme/src/fun.c b/src/mzscheme/src/fun.c index e3fbcbeb6d..86e35a220a 100644 --- a/src/mzscheme/src/fun.c +++ b/src/mzscheme/src/fun.c @@ -1242,10 +1242,6 @@ int scheme_closure_body_size(Scheme_Closure_Data *data, int check_assign, Optimi cl = (Closure_Info *)data->closure_map; if (check_assign) { - /* Don't try to inline if there's a rest arg: */ - if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) - return -1; - /* Don't try to inline if any arguments are mutated: */ for (i = data->num_params; i--; ) { if (cl->local_flags[i] & SCHEME_WAS_SET_BANGED) diff --git a/src/mzscheme/src/future.c b/src/mzscheme/src/future.c index 31ff13b92b..0b5930b6df 100644 --- a/src/mzscheme/src/future.c +++ b/src/mzscheme/src/future.c @@ -35,7 +35,7 @@ static Scheme_Object *future_p(int argc, Scheme_Object *argv[]) static void register_traversers(void); #endif -#ifndef FUTURES_ENABLED +#ifndef MZ_USE_FUTURES /* Futures not enabled, but make a stub module and implementation */ @@ -176,12 +176,12 @@ typedef struct Scheme_Future_State { future_t *future_waiting_atomic; int next_futureid; - pthread_mutex_t future_mutex; - pthread_cond_t future_pending_cv; - pthread_cond_t gc_ok_c; - pthread_cond_t gc_done_c; + mzrt_mutex *future_mutex; + mzrt_sema *future_pending_sema; + mzrt_sema *gc_ok_c; + mzrt_sema *gc_done_c; - int gc_not_ok, wait_for_gc; + int gc_not_ok, wait_for_gc, need_gc_ok_post, need_gc_done_post; int *gc_counter_ptr; @@ -190,9 +190,8 @@ typedef struct Scheme_Future_State { typedef struct Scheme_Future_Thread_State { int id; - pthread_t threadid; int worker_gc_counter; - pthread_cond_t worker_can_continue_cv; + mzrt_sema *worker_can_continue_sema; future_t *current_ft; long runstack_size; @@ -232,53 +231,12 @@ static void send_special_result(future_t *f, Scheme_Object *retval); # define scheme_future_longjmp(newbuf, v) scheme_longjmp(newbuf, v) #endif -/**********************************************************************/ -/* Semaphore helpers */ -/**********************************************************************/ - -typedef struct sema_t { - int ready; - pthread_mutex_t m; - pthread_cond_t c; -} sema_t; - -static void sema_wait(sema_t *s) -{ - pthread_mutex_lock(&s->m); - while (!s->ready) { - pthread_cond_wait(&s->c, &s->m); - } - --s->ready; - pthread_mutex_unlock(&s->m); -} - -static void sema_signal(sema_t *s) -{ - pthread_mutex_lock(&s->m); - s->ready++; - pthread_cond_signal(&s->c); - pthread_mutex_unlock(&s->m); -} - -static void sema_init(sema_t *s) -{ - pthread_mutex_init(&s->m, NULL); - pthread_cond_init(&s->c, NULL); - s->ready = 0; -} - -static void sema_destroy(sema_t *s) -{ - pthread_mutex_destroy(&s->m); - pthread_cond_destroy(&s->c); -} - /**********************************************************************/ /* Arguments for a newly created future thread */ /**********************************************************************/ typedef struct future_thread_params_t { - struct sema_t ready_sema; + mzrt_sema *ready_sema; struct NewGC *shared_GC; Scheme_Future_State *fs; Scheme_Future_Thread_State *fts; @@ -361,10 +319,10 @@ void futures_init(void) REGISTER_SO(fs->future_queue_end); REGISTER_SO(fs->future_waiting_atomic); - pthread_mutex_init(&fs->future_mutex, NULL); - pthread_cond_init(&fs->future_pending_cv, NULL); - pthread_cond_init(&fs->gc_ok_c, NULL); - pthread_cond_init(&fs->gc_done_c, NULL); + mzrt_mutex_create(&fs->future_mutex); + mzrt_sema_create(&fs->future_pending_sema, 0); + mzrt_sema_create(&fs->gc_ok_c, 0); + mzrt_sema_create(&fs->gc_done_c, 0); fs->gc_counter_ptr = &scheme_did_gc_count; @@ -380,13 +338,11 @@ static void init_future_thread(Scheme_Future_State *fs, int i) { Scheme_Future_Thread_State *fts; GC_CAN_IGNORE future_thread_params_t params; - pthread_t threadid; - GC_CAN_IGNORE pthread_attr_t attr; + Scheme_Thread *skeleton; + Scheme_Object **runstack_start; //Create the worker thread pool. These threads will //'queue up' and wait for futures to become available - pthread_attr_init(&attr); - pthread_attr_setstacksize(&attr, INITIAL_C_STACK_SIZE); fts = (Scheme_Future_Thread_State *)malloc(sizeof(Scheme_Future_Thread_State)); memset(fts, 0, sizeof(Scheme_Future_Thread_State)); @@ -397,24 +353,27 @@ static void init_future_thread(Scheme_Future_State *fs, int i) params.fs = fs; /* Make enough of a thread record to deal with multiple values. */ - params.thread_skeleton = MALLOC_ONE_TAGGED(Scheme_Thread); - params.thread_skeleton->so.type = scheme_thread_type; + skeleton = MALLOC_ONE_TAGGED(Scheme_Thread); + skeleton->so.type = scheme_thread_type; { Scheme_Object **rs_start, **rs; 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; + runstack_start = rs_start; fts->runstack_size = init_runstack_size; } - sema_init(¶ms.ready_sema); - pthread_create(&threadid, &attr, worker_thread_future_loop, ¶ms); - sema_wait(¶ms.ready_sema); - sema_destroy(¶ms.ready_sema); + /* Fill in GCable values just before creating the thread, + because the GC ignores `params': */ + params.thread_skeleton = skeleton; + params.runstack_start = runstack_start; - fts->threadid = threadid; + mzrt_sema_create(¶ms.ready_sema, 0); + mz_proc_thread_create_w_stacksize(worker_thread_future_loop, ¶ms, INITIAL_C_STACK_SIZE); + mzrt_sema_wait(params.ready_sema); + mzrt_sema_destroy(params.ready_sema); fts->gen0_size = 1; @@ -428,9 +387,13 @@ static void init_future_thread(Scheme_Future_State *fs, int i) } static void start_gc_not_ok(Scheme_Future_State *fs) +/* must have mutex_lock */ { while (fs->wait_for_gc) { - pthread_cond_wait(&fs->gc_done_c, &fs->future_mutex); + fs->need_gc_done_post++; + mzrt_mutex_unlock(fs->future_mutex); + mzrt_sema_wait(fs->gc_done_c); + mzrt_mutex_lock(fs->future_mutex); } fs->gc_not_ok++; @@ -452,6 +415,7 @@ static void start_gc_not_ok(Scheme_Future_State *fs) static void end_gc_not_ok(Scheme_Future_Thread_State *fts, Scheme_Future_State *fs, Scheme_Object **current_rs) +/* must have mutex_lock */ { scheme_set_runstack_limits(MZ_RUNSTACK_START, fts->runstack_size, @@ -463,7 +427,10 @@ static void end_gc_not_ok(Scheme_Future_Thread_State *fts, /* FIXME: clear scheme_current_thread->ku.multiple.array ? */ --fs->gc_not_ok; - pthread_cond_signal(&fs->gc_ok_c); + if (fs->need_gc_ok_post) { + fs->need_gc_ok_post = 0; + mzrt_sema_post(fs->gc_ok_c); + } } void scheme_future_block_until_gc() @@ -473,9 +440,9 @@ void scheme_future_block_until_gc() if (!fs) return; - pthread_mutex_lock(&fs->future_mutex); + mzrt_mutex_lock(fs->future_mutex); fs->wait_for_gc = 1; - pthread_mutex_unlock(&fs->future_mutex); + mzrt_mutex_unlock(fs->future_mutex); for (i = 0; i < THREAD_POOL_SIZE; i++) { if (fs->pool_threads[i]) { @@ -486,11 +453,14 @@ void scheme_future_block_until_gc() } asm("mfence"); - pthread_mutex_lock(&fs->future_mutex); + mzrt_mutex_lock(fs->future_mutex); while (fs->gc_not_ok) { - pthread_cond_wait(&fs->gc_ok_c, &fs->future_mutex); + fs->need_gc_ok_post = 1; + mzrt_mutex_unlock(fs->future_mutex); + mzrt_sema_wait(fs->gc_ok_c); + mzrt_mutex_lock(fs->future_mutex); } - pthread_mutex_unlock(&fs->future_mutex); + mzrt_mutex_unlock(fs->future_mutex); } void scheme_future_continue_after_gc() @@ -508,10 +478,13 @@ void scheme_future_continue_after_gc() } } - pthread_mutex_lock(&fs->future_mutex); + mzrt_mutex_lock(fs->future_mutex); fs->wait_for_gc = 0; - pthread_cond_broadcast(&fs->gc_done_c); - pthread_mutex_unlock(&fs->future_mutex); + while (fs->need_gc_done_post) { + --fs->need_gc_done_post; + mzrt_sema_post(fs->gc_done_c); + } + mzrt_mutex_unlock(fs->future_mutex); } void scheme_future_gc_pause() @@ -520,10 +493,10 @@ void scheme_future_gc_pause() Scheme_Future_Thread_State *fts = scheme_future_thread_state; Scheme_Future_State *fs = scheme_future_state; - pthread_mutex_lock(&fs->future_mutex); + mzrt_mutex_lock(fs->future_mutex); end_gc_not_ok(fts, fs, MZ_RUNSTACK); start_gc_not_ok(fs); /* waits until wait_for_gc is 0 */ - pthread_mutex_unlock(&fs->future_mutex); + mzrt_mutex_unlock(fs->future_mutex); } /**********************************************************************/ @@ -544,9 +517,9 @@ Scheme_Object *future(int argc, Scheme_Object *argv[]) scheme_check_proc_arity("future", 0, 0, argc, argv); if (fs->future_threads_created < THREAD_POOL_SIZE) { - pthread_mutex_lock(&fs->future_mutex); + mzrt_mutex_lock(fs->future_mutex); count = fs->future_queue_count; - pthread_mutex_unlock(&fs->future_mutex); + mzrt_mutex_unlock(fs->future_mutex); if (count >= fs->future_threads_created) { init_future_thread(fs, fs->future_threads_created); fs->future_threads_created++; @@ -566,10 +539,6 @@ Scheme_Object *future(int argc, Scheme_Object *argv[]) ft->status = PENDING; //JIT compile the code if not already jitted - //Temporarily repoint MZ_RUNSTACK - //to the worker thread's runstack - - //in case the JIT compiler uses the stack address - //when generating code if (ncd->code == scheme_on_demand_jit_code) { scheme_on_demand_generate_lambda(nc, 0, NULL); @@ -582,11 +551,11 @@ Scheme_Object *future(int argc, Scheme_Object *argv[]) ft->code = (void*)ncd->code; - pthread_mutex_lock(&fs->future_mutex); + mzrt_mutex_lock(fs->future_mutex); enqueue_future(fs, ft); //Signal that a future is pending - pthread_cond_signal(&fs->future_pending_cv); - pthread_mutex_unlock(&fs->future_mutex); + mzrt_sema_post(fs->future_pending_sema); + mzrt_mutex_unlock(fs->future_mutex); return (Scheme_Object*)ft; } @@ -599,11 +568,11 @@ int future_ready(Scheme_Object *obj) int ret = 0; future_t *ft = (future_t*)obj; - pthread_mutex_lock(&fs->future_mutex); + mzrt_mutex_lock(fs->future_mutex); if (ft->work_completed || ft->rt_prim) { ret = 1; } - pthread_mutex_unlock(&fs->future_mutex); + mzrt_mutex_unlock(fs->future_mutex); return ret; } @@ -645,62 +614,61 @@ Scheme_Object *touch(int argc, Scheme_Object *argv[]) dump_state(); #endif - pthread_mutex_lock(&fs->future_mutex); + mzrt_mutex_lock(fs->future_mutex); 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); + mzrt_mutex_unlock(fs->future_mutex); retval = scheme_apply_multi(ft->orig_lambda, 0, NULL); send_special_result(ft, retval); - pthread_mutex_lock(&fs->future_mutex); + mzrt_mutex_lock(fs->future_mutex); ft->work_completed = 1; ft->retval = retval; ft->status = FINISHED; dequeue_future(fs, ft); - pthread_mutex_unlock(&fs->future_mutex); + mzrt_mutex_unlock(fs->future_mutex); receive_special_result(ft, retval, 0); return retval; } - pthread_mutex_unlock(&fs->future_mutex); + mzrt_mutex_unlock(fs->future_mutex); //Spin waiting for primitive calls or a return value from //the worker thread - wait_for_rtcall_or_completion: - scheme_block_until(future_ready, NULL, (Scheme_Object*)ft, 0); - pthread_mutex_lock(&fs->future_mutex); - if (ft->work_completed) - { - retval = ft->retval; + while (1) { + scheme_block_until(future_ready, NULL, (Scheme_Object*)ft, 0); + mzrt_mutex_lock(fs->future_mutex); + if (ft->work_completed) + { + retval = ft->retval; - LOG("Successfully touched future %d\n", ft->id); - // fflush(stdout); + LOG("Successfully touched future %d\n", ft->id); + // fflush(stdout); - pthread_mutex_unlock(&fs->future_mutex); - } - else if (ft->rt_prim) - { - //Invoke the primitive and stash the result - //Release the lock so other threads can manipulate the queue - //while the runtime call executes - pthread_mutex_unlock(&fs->future_mutex); - LOG("Invoking primitive %p on behalf of future %d...", ft->rt_prim, ft->id); - invoke_rtcall(fs, ft); - LOG("done.\n"); - - goto wait_for_rtcall_or_completion; - } - else - { - pthread_mutex_unlock(&fs->future_mutex); - goto wait_for_rtcall_or_completion; - } + mzrt_mutex_unlock(fs->future_mutex); + break; + } + else if (ft->rt_prim) + { + //Invoke the primitive and stash the result + //Release the lock so other threads can manipulate the queue + //while the runtime call executes + mzrt_mutex_unlock(fs->future_mutex); + LOG("Invoking primitive %p on behalf of future %d...", ft->rt_prim, ft->id); + invoke_rtcall(fs, ft); + LOG("done.\n"); + } + else + { + mzrt_mutex_unlock(fs->future_mutex); + } + } if (!retval) { scheme_signal_error("touch: future previously aborted"); @@ -762,8 +730,6 @@ void *worker_thread_future_loop(void *arg) future_t *ft; mz_jmp_buf newbuf; - scheme_init_os_thread(); - scheme_future_state = fs; scheme_future_thread_state = fts; @@ -771,7 +737,7 @@ void *worker_thread_future_loop(void *arg) scheme_current_thread = params->thread_skeleton; //Set processor affinity - /*pthread_mutex_lock(&fs->future_mutex); + /*mzrt_mutex_lock(fs->future_mutex); static unsigned long cur_cpu_mask = 1; if (pthread_setaffinity_np(pthread_self(), sizeof(g_cur_cpu_mask), &g_cur_cpu_mask)) { @@ -781,10 +747,10 @@ void *worker_thread_future_loop(void *arg) pthread_self()); } - pthread_mutex_unlock(&fs->future_mutex); + mzrt_mutex_unlock(fs->future_mutex); */ - pthread_cond_init(&fts->worker_can_continue_cv, NULL); + mzrt_sema_create(&fts->worker_can_continue_sema, 0); scheme_use_rtcall = 1; @@ -803,81 +769,77 @@ void *worker_thread_future_loop(void *arg) params->current_thread_ptr = &scheme_current_thread; params->jit_future_storage_ptr = &jit_future_storage[0]; - sema_signal(¶ms->ready_sema); + mzrt_sema_post(params->ready_sema); - wait_for_work: - pthread_mutex_lock(&fs->future_mutex); - start_gc_not_ok(fs); - while (!(ft = get_pending_future(fs))) { - end_gc_not_ok(fts, fs, NULL); - pthread_cond_wait(&fs->future_pending_cv, &fs->future_mutex); + while (1) { + mzrt_sema_wait(fs->future_pending_sema); + mzrt_mutex_lock(fs->future_mutex); start_gc_not_ok(fs); - } + ft = get_pending_future(fs); - LOG("Got a signal that a future is pending..."); + if (ft) { + LOG("Got a signal that a future is pending..."); - //Work is available for this thread - ft->status = RUNNING; - pthread_mutex_unlock(&fs->future_mutex); + //Work is available for this thread + ft->status = RUNNING; + mzrt_mutex_unlock(fs->future_mutex); - ft->threadid = fts->threadid; - ft->thread_short_id = fts->id; + ft->thread_short_id = fts->id; - //Set up the JIT compiler for this thread - scheme_jit_fill_threadlocal_table(); + //Set up the JIT compiler for this thread + scheme_jit_fill_threadlocal_table(); - jitcode = (Scheme_Object* (*)(Scheme_Object*, int, Scheme_Object**))(ft->code); + jitcode = (Scheme_Object* (*)(Scheme_Object*, int, Scheme_Object**))(ft->code); - fts->current_ft = ft; + fts->current_ft = ft; - //Run the code - //Passing no arguments for now. - //The lambda passed to a future will always be a parameterless - //function. - //From this thread's perspective, this call will never return - //until all the work to be done in the future has been completed, - //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); + //Run the code + //Passing no arguments for now. + //The lambda passed to a future will always be a parameterless + //function. + //From this thread's perspective, this call will never return + //until all the work to be done in the future has been completed, + //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); - MZ_RUNSTACK = MZ_RUNSTACK_START + fts->runstack_size; + MZ_RUNSTACK = MZ_RUNSTACK_START + fts->runstack_size; - scheme_current_thread->error_buf = &newbuf; - if (scheme_future_setjmp(newbuf)) { - /* failed */ - v = NULL; - } else { - v = jitcode(ft->orig_lambda, 0, NULL); - if (SAME_OBJ(v, SCHEME_TAIL_CALL_WAITING)) { - v = scheme_ts_scheme_force_value_same_mark(v); - } - } + scheme_current_thread->error_buf = &newbuf; + if (scheme_future_setjmp(newbuf)) { + /* failed */ + v = NULL; + } else { + v = jitcode(ft->orig_lambda, 0, NULL); + if (SAME_OBJ(v, SCHEME_TAIL_CALL_WAITING)) { + v = scheme_ts_scheme_force_value_same_mark(v); + } + } - LOG("Finished running JIT code at %p.\n", ft->code); + LOG("Finished running JIT code at %p.\n", ft->code); - // Get future again, since a GC may have occurred - ft = fts->current_ft; + // Get future again, since a GC may have occurred + ft = fts->current_ft; - //Set the return val in the descriptor - pthread_mutex_lock(&fs->future_mutex); - ft->work_completed = 1; - ft->retval = v; + //Set the return val in the descriptor + mzrt_mutex_lock(fs->future_mutex); + ft->work_completed = 1; + ft->retval = v; - /* In case of multiple values: */ - send_special_result(ft, v); + /* In case of multiple values: */ + send_special_result(ft, v); - //Update the status - ft->status = FINISHED; - dequeue_future(fs, ft); + //Update the status + ft->status = FINISHED; + dequeue_future(fs, ft); - scheme_signal_received_at(fs->signal_handle); + scheme_signal_received_at(fs->signal_handle); - end_gc_not_ok(fts, fs, NULL); - - pthread_mutex_unlock(&fs->future_mutex); - - goto wait_for_work; + } + end_gc_not_ok(fts, fs, NULL); + mzrt_mutex_unlock(fs->future_mutex); + } return NULL; } @@ -895,14 +857,14 @@ void scheme_check_future_work() while (1) { /* Try to get a future waiting on a atomic operation */ - pthread_mutex_lock(&fs->future_mutex); + mzrt_mutex_lock(fs->future_mutex); ft = fs->future_waiting_atomic; if (ft) { fs->future_waiting_atomic = ft->next_waiting_atomic; ft->next_waiting_atomic = NULL; ft->waiting_atomic = 0; } - pthread_mutex_unlock(&fs->future_mutex); + mzrt_mutex_unlock(fs->future_mutex); if (ft) { if (ft->rt_prim && ft->rt_prim_is_atomic) { @@ -931,7 +893,7 @@ static void future_do_runtimecall(Scheme_Future_Thread_State *fts, //set up the arguments for the runtime call //to be picked up by the main rt thread - pthread_mutex_lock(&fs->future_mutex); + mzrt_mutex_lock(fs->future_mutex); future->prim_func = func; future->rt_prim = 1; @@ -951,17 +913,19 @@ static void future_do_runtimecall(Scheme_Future_Thread_State *fts, scheme_signal_received_at(fs->signal_handle); //Wait for the signal that the RT call is finished - future->can_continue_cv = &fts->worker_can_continue_cv; - while (future->can_continue_cv) { - end_gc_not_ok(fts, fs, MZ_RUNSTACK); - pthread_cond_wait(&fts->worker_can_continue_cv, &fs->future_mutex); - start_gc_not_ok(fs); - //Fetch the future instance again, in case the GC has moved the pointer - future = fts->current_ft; - } + future->can_continue_sema = fts->worker_can_continue_sema; + end_gc_not_ok(fts, fs, MZ_RUNSTACK); + mzrt_mutex_unlock(fs->future_mutex); - pthread_mutex_unlock(&fs->future_mutex); + mzrt_sema_wait(fts->worker_can_continue_sema); + mzrt_mutex_lock(fs->future_mutex); + start_gc_not_ok(fs); + mzrt_mutex_unlock(fs->future_mutex); + + //Fetch the future instance again, in case the GC has moved the pointer + future = fts->current_ft; + if (future->no_retval) { future->no_retval = 0; scheme_future_longjmp(*scheme_current_thread->error_buf, 1); @@ -1158,14 +1122,14 @@ static void do_invoke_rtcall(Scheme_Future_State *fs, future_t *future) break; } - pthread_mutex_lock(&fs->future_mutex); + mzrt_mutex_lock(fs->future_mutex); //Signal the waiting worker thread that it //can continue running machine code - if (future->can_continue_cv) { - pthread_cond_signal(future->can_continue_cv); - future->can_continue_cv= NULL; + if (future->can_continue_sema) { + mzrt_sema_post(future->can_continue_sema); + future->can_continue_sema= NULL; } - pthread_mutex_unlock(&fs->future_mutex); + mzrt_mutex_unlock(fs->future_mutex); } static void *do_invoke_rtcall_k(void) @@ -1190,14 +1154,14 @@ static void invoke_rtcall(Scheme_Future_State * volatile fs, future_t * volatile savebuf = p->error_buf; p->error_buf = &newbuf; if (scheme_setjmp(newbuf)) { - pthread_mutex_lock(&fs->future_mutex); + mzrt_mutex_lock(fs->future_mutex); future->no_retval = 1; future->work_completed = 1; //Signal the waiting worker thread that it //can continue running machine code - pthread_cond_signal(future->can_continue_cv); - future->can_continue_cv = NULL; - pthread_mutex_unlock(&fs->future_mutex); + mzrt_sema_post(future->can_continue_sema); + future->can_continue_sema = NULL; + mzrt_mutex_unlock(fs->future_mutex); scheme_longjmp(*savebuf, 1); } else { if (future->rt_prim_is_atomic) { @@ -1262,7 +1226,7 @@ START_XFORM_SKIP; static void register_traversers(void) { -#ifdef FUTURES_ENABLED +#ifdef MZ_USE_FUTURES GC_REG_TRAV(scheme_future_type, future); #else GC_REG_TRAV(scheme_future_type, sequential_future); diff --git a/src/mzscheme/src/future.h b/src/mzscheme/src/future.h index 321177c60c..3652806522 100644 --- a/src/mzscheme/src/future.h +++ b/src/mzscheme/src/future.h @@ -20,7 +20,6 @@ void scheme_add_global(char *name, int arity, Scheme_Env *env); int scheme_make_prim_w_arity(prim_t func, char *name, int arg1, int arg2); #endif -#include "pthread.h" #include typedef void (*prim_void_void_3args_t)(Scheme_Object **); @@ -43,11 +42,10 @@ typedef struct future_t { Scheme_Object so; int id; - pthread_t threadid; int thread_short_id; int status; int work_completed; - pthread_cond_t *can_continue_cv; + mzrt_sema *can_continue_sema; Scheme_Object *orig_lambda; void *code; @@ -111,7 +109,7 @@ typedef struct future_t { extern Scheme_Object *scheme_ts_scheme_force_value_same_mark(Scheme_Object *v); //Helper macros for argument marshaling -#ifdef FUTURES_ENABLED +#ifdef MZ_USE_FUTURES #define IS_WORKER_THREAD (g_rt_threadid != 0 && pthread_self() != g_rt_threadid) #define ASSERT_CORRECT_THREAD if (g_rt_threadid != 0 && pthread_self() != g_rt_threadid) \ diff --git a/src/mzscheme/src/gmp/gmp.c b/src/mzscheme/src/gmp/gmp.c index 654f16c095..59d9ad25d3 100644 --- a/src/mzscheme/src/gmp/gmp.c +++ b/src/mzscheme/src/gmp/gmp.c @@ -5788,6 +5788,7 @@ void scheme_init_gmp_places() { gmp_tmp_xxx.alloc_point = &gmp_tmp_xxx; gmp_tmp_xxx.prev = 0; gmp_tmp_current = &gmp_tmp_xxx; + REGISTER_SO(gmp_mem_pool); } void scheme_gmp_tls_init(long *s) diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index edfa649a1a..dcc2bb189e 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -42,7 +42,7 @@ #include "schpriv.h" #include "schmach.h" -#ifdef FUTURES_ENABLED +#ifdef MZ_USE_FUTURES # include "future.h" #endif #ifdef MZ_USE_DWARF_LIBUNWIND @@ -1968,10 +1968,14 @@ static int no_sync_change(Scheme_Object *obj, int fuel) fuel = no_sync_change(branch->tbranch, fuel); return no_sync_change(branch->fbranch, fuel); } - case scheme_toplevel_type: case scheme_local_type: + if (SCHEME_GET_LOCAL_FLAGS(obj) == SCHEME_LOCAL_FLONUM) + return 0; + else + return fuel - 1; + case scheme_toplevel_type: case scheme_local_unbox_type: - return fuel - 1; + return fuel - 1; default: if (t > _scheme_values_types_) return fuel - 1; @@ -2274,8 +2278,13 @@ static int is_non_gc(Scheme_Object *obj, int depth) case scheme_unclosed_procedure_type: break; - case scheme_quote_syntax_type: case scheme_local_type: + if (SCHEME_GET_LOCAL_FLAGS(obj) == SCHEME_LOCAL_FLONUM) + return 0; + return 1; + break; + + case scheme_quote_syntax_type: case scheme_local_unbox_type: return 1; break; @@ -2316,12 +2325,16 @@ static int is_relatively_constant_and_avoids_r1(Scheme_Object *obj, Scheme_Objec 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; + /* Must have clearing, other-clears, or flonum flag set */ + if (SCHEME_GET_LOCAL_FLAGS(obj) == SCHEME_LOCAL_FLONUM) + return 0; + else { + 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; + } } } @@ -2557,7 +2570,7 @@ extern int g_print_prims; #include "jit_ts.c" /* Support for intercepting direct calls to primitives: */ -#ifdef FUTURES_ENABLED +#ifdef MZ_USE_FUTURES # define mz_prepare_direct_prim(n) mz_prepare(n) # define mz_finishr_direct_prim(reg, proc) (jit_pusharg_p(reg), (void)mz_finish(proc)) # define mz_direct_only(p) /* skip this arg, so that total count <= 3 args */ @@ -2676,7 +2689,7 @@ static int generate_pause_for_gc_and_retry(mz_jit_state *jitter, int gc_reg, /* must not be JIT_R1 */ GC_CAN_IGNORE jit_insn *refagain) { -#ifdef FUTURES_ENABLED +#ifdef MZ_USE_FUTURES GC_CAN_IGNORE jit_insn *refslow = 0, *refpause; int i; @@ -3905,10 +3918,12 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ if (num_rands) { /* Save rator where GC can see it */ Scheme_Type t; - t = SCHEME_TYPE((alt_rands - ? alt_rands[1+args_already_in_place] - : app->args[1+args_already_in_place])); - if ((num_rands == 1) && (SAME_TYPE(scheme_local_type, t) + arg = (alt_rands + ? alt_rands[1+args_already_in_place] + : app->args[1+args_already_in_place]); + t = SCHEME_TYPE(arg); + if ((num_rands == 1) && ((SAME_TYPE(scheme_local_type, t) + && ((SCHEME_GET_LOCAL_FLAGS(arg) != SCHEME_LOCAL_FLONUM))) || (t >= _scheme_values_types_))) { /* App of something complex to a local variable. We can move the proc directly to V1. */ @@ -4217,8 +4232,9 @@ static int can_unbox_inline(Scheme_Object *obj, int fuel, int regs, int unsafely Scheme_App3_Rec *app = (Scheme_App3_Rec *)obj; if (!is_inline_unboxable_op(app->rator, SCHEME_PRIM_IS_BINARY_INLINED, unsafely, 0)) return 0; - if (IS_NAMED_PRIM(app->rator, "unsafe-f64vector-ref") - || IS_NAMED_PRIM(app->rator, "unsafe-flvector-ref")) { + if ((SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_BINARY_INLINED) + && (IS_NAMED_PRIM(app->rator, "unsafe-f64vector-ref") + || IS_NAMED_PRIM(app->rator, "unsafe-flvector-ref"))) { if (is_unboxing_immediate(app->rand1, 1) && is_unboxing_immediate(app->rand1, 2)) { return 1; diff --git a/src/mzscheme/src/jit_ts.c b/src/mzscheme/src/jit_ts.c index 640e456944..63539556ca 100644 --- a/src/mzscheme/src/jit_ts.c +++ b/src/mzscheme/src/jit_ts.c @@ -1,4 +1,4 @@ -#ifdef FUTURES_ENABLED +#ifdef MZ_USE_FUTURES # include "jit_ts_def.c" diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index 292cce7c68..f8f526d521 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -199,6 +199,9 @@ READ_ONLY static Scheme_Object *empty_self_modidx; READ_ONLY static Scheme_Object *empty_self_modname; THREAD_LOCAL_DECL(static Scheme_Bucket_Table *starts_table); +#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) +THREAD_LOCAL_DECL(static Scheme_Bucket_Table *place_local_modpath_table); +#endif /* FIXME eventually theses initial objects should be shared, but work required */ THREAD_LOCAL_DECL(static Scheme_Env *initial_modules_env); @@ -408,6 +411,10 @@ void scheme_init_module_resolver(void) REGISTER_SO(starts_table); starts_table = scheme_make_weak_equal_table(); +#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) + REGISTER_SO(place_local_modpath_table); + place_local_modpath_table = scheme_make_weak_equal_table(); +#endif config = scheme_current_config(); @@ -2870,10 +2877,36 @@ Scheme_Object *scheme_intern_resolved_module_path_worker(Scheme_Object *o) return return_value; } +#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) +static Scheme_Object *scheme_intern_local_resolved_module_path_worker(Scheme_Object *o) +{ + Scheme_Object *rmp; + Scheme_Bucket *b; + Scheme_Object *return_value; + + rmp = scheme_alloc_small_object(); + rmp->type = scheme_resolved_module_path_type; + SCHEME_PTR_VAL(rmp) = o; + + scheme_start_atomic(); + b = scheme_bucket_from_table(place_local_modpath_table, (const char *)rmp); + scheme_end_atomic_no_swap(); + if (!b->val) + b->val = scheme_true; + + return_value = (Scheme_Object *)HT_EXTRACT_WEAK(b->key); + + return return_value; +} +#endif + Scheme_Object *scheme_intern_resolved_module_path(Scheme_Object *o) { #if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) void *return_payload; + if (SCHEME_SYMBOLP(o) && SCHEME_SYM_UNINTERNEDP(o)) { + return scheme_intern_local_resolved_module_path_worker(o); + } return_payload = scheme_master_fast_path(1, o); return (Scheme_Object*) return_payload; #endif @@ -4399,7 +4432,7 @@ void *scheme_module_run_finish(Scheme_Env *menv, Scheme_Env *env) save_runstack = scheme_push_prefix(menv, m->prefix, m->me->src_modidx, menv->link_midx, - 0, menv->phase); + 0, menv->phase, NULL); p = scheme_current_thread; save_phase_shift = p->current_phase_shift; @@ -4782,7 +4815,8 @@ static void eval_exptime(Scheme_Object *names, int count, save_runstack = scheme_push_prefix(genv, rp, (shift ? genv->module->me->src_modidx : NULL), (shift ? genv->link_midx : NULL), - 1, genv->phase); + 1, genv->phase, + NULL); if (is_simple_expr(expr)) { vals = _scheme_eval_linked_expr_multi_wp(expr, scheme_current_thread); diff --git a/src/mzscheme/src/mzmark.c b/src/mzscheme/src/mzmark.c index afe07e3be9..9a124b8c81 100644 --- a/src/mzscheme/src/mzmark.c +++ b/src/mzscheme/src/mzmark.c @@ -5503,7 +5503,7 @@ static int native_unclosed_proc_plus_case_FIXUP(void *p) { #ifdef MARKS_FOR_FUTURE_C -#ifdef FUTURES_ENABLED +#ifdef MZ_USE_FUTURES static int future_SIZE(void *p) { return diff --git a/src/mzscheme/src/mzmarksrc.c b/src/mzscheme/src/mzmarksrc.c index 8a0051a7ea..861a1367f2 100644 --- a/src/mzscheme/src/mzmarksrc.c +++ b/src/mzscheme/src/mzmarksrc.c @@ -2253,7 +2253,7 @@ END jit; START future; -#ifdef FUTURES_ENABLED +#ifdef MZ_USE_FUTURES future { mark: diff --git a/src/mzscheme/src/mzrt.c b/src/mzscheme/src/mzrt.c index 17fc1e8f1a..a7b9cef979 100644 --- a/src/mzscheme/src/mzrt.c +++ b/src/mzscheme/src/mzrt.c @@ -1,6 +1,6 @@ #include "schpriv.h" -#ifdef MZ_USE_PLACES +#ifdef MZ_USE_MZRT /************************************************************************/ /************************************************************************/ @@ -194,18 +194,19 @@ mz_proc_thread* mzrt_proc_first_thread_init() { return thread; } -mz_proc_thread* mz_proc_thread_create(mz_proc_thread_start start_proc, void* data) { +mz_proc_thread* mz_proc_thread_create_w_stacksize(mz_proc_thread_start start_proc, void* data, long stacksize) { mz_proc_thread *thread = (mz_proc_thread*)malloc(sizeof(mz_proc_thread)); +# ifndef WIN32 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 + + if (stacksize) { + attr = &attr_storage; + pthread_attr_init(attr); + pthread_attr_setstacksize(attr, stacksize); /*8MB*/ + } else + attr = NULL; +# endif mzrt_thread_stub_data *stub_data = (mzrt_thread_stub_data*)malloc(sizeof(mzrt_thread_stub_data)); thread->mbox = pt_mbox_create(); @@ -213,7 +214,7 @@ mz_proc_thread* mz_proc_thread_create(mz_proc_thread_start start_proc, void* dat stub_data->data = data; stub_data->thread = thread; # ifdef WIN32 - thread->threadid = CreateThread(NULL, 0, mzrt_thread_stub, stub_data, 0, NULL); + thread->threadid = CreateThread(NULL, stacksize, mzrt_thread_stub, stub_data, 0, NULL); # else pthread_create(&thread->threadid, attr, mzrt_thread_stub, stub_data); # endif @@ -221,6 +222,18 @@ mz_proc_thread* mz_proc_thread_create(mz_proc_thread_start start_proc, void* dat return thread; } +mz_proc_thread* mz_proc_thread_create(mz_proc_thread_start start_proc, void* data) { + long stacksize; + +#ifdef OS_X + stacksize = 8*1024*1024; +#else + stacksize = 0; +#endif + + return mz_proc_thread_create_w_stacksize(start_proc, data, stacksize); +} + void * mz_proc_thread_wait(mz_proc_thread *thread) { #ifdef WIN32 DWORD rc; @@ -253,6 +266,18 @@ int mz_proc_thread_detach(mz_proc_thread *thread) { #endif } +void mz_proc_thread_exit(void *rc) { +#ifdef WIN32 + ExitThread((DWORD)rc); +#else +# ifndef MZ_PRECISE_GC + pthread_exit(rc); +# else + pthread_exit(rc); +# endif +#endif +} + /***********************************************************************/ /* RW Lock */ /***********************************************************************/ diff --git a/src/mzscheme/src/mzrt.h b/src/mzscheme/src/mzrt.h index a18ab2d349..954d77dc60 100644 --- a/src/mzscheme/src/mzrt.h +++ b/src/mzscheme/src/mzrt.h @@ -1,7 +1,7 @@ #ifndef MZRT_H #define MZRT_H -#ifdef MZ_USE_PLACES +#ifdef MZ_USE_MZRT /****************** ATOMIC OPERATIONS ************************************/ /* mzrt_atomic_ops.c */ @@ -44,8 +44,10 @@ 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); +mz_proc_thread* mz_proc_thread_create_w_stacksize(mz_proc_thread_start*, void* data, long stacksize); void *mz_proc_thread_wait(mz_proc_thread *thread); int mz_proc_thread_detach(mz_proc_thread *thread); +void mz_proc_thread_exit(void *rc); void mzrt_sleep(int seconds); diff --git a/src/mzscheme/src/places.c b/src/mzscheme/src/places.c index 93192b60a9..eb9566a314 100644 --- a/src/mzscheme/src/places.c +++ b/src/mzscheme/src/places.c @@ -7,6 +7,7 @@ #include "mzrt.h" +READ_ONLY static Scheme_Object *scheme_def_place_exit_proc; SHARED_OK mz_proc_thread *scheme_master_proc_thread; THREAD_LOCAL_DECL(mz_proc_thread *proc_thread_self); @@ -17,6 +18,8 @@ static Scheme_Object *scheme_place_p(int argc, Scheme_Object *args[]); static Scheme_Object *scheme_places_deep_copy_in_master(Scheme_Object *so); static Scheme_Object *scheme_place_send(int argc, Scheme_Object *args[]); static Scheme_Object *scheme_place_recv(int argc, Scheme_Object *args[]); +static Scheme_Object *scheme_place_ch_p(int argc, Scheme_Object *args[]); +static Scheme_Object *def_place_exit_handler_proc(int argc, Scheme_Object *args[]); Scheme_Object *scheme_place_async_channel_create(); void scheme_place_async_send(Scheme_Place_Async_Channel *ch, Scheme_Object *o); @@ -42,7 +45,6 @@ static Scheme_Object *not_implemented(int argc, Scheme_Object **argv) # ifdef MZ_PRECISE_GC static void register_traversers(void) { } - # endif #endif @@ -66,8 +68,14 @@ void scheme_init_place(Scheme_Env *env) PLACE_PRIM_W_ARITY("place?", scheme_place_p, 1, 1, plenv); PLACE_PRIM_W_ARITY("place-ch-send", scheme_place_send, 1, 2, plenv); PLACE_PRIM_W_ARITY("place-ch-recv", scheme_place_recv, 1, 1, plenv); + PLACE_PRIM_W_ARITY("place-ch?", scheme_place_ch_p, 1, 1, plenv); +#ifdef MZ_USE_PLACES + REGISTER_SO(scheme_def_place_exit_proc); + scheme_def_place_exit_proc = scheme_make_prim_w_arity(def_place_exit_handler_proc, "default-place-exit-handler", 1, 1); +#endif scheme_finish_primitive_module(plenv); + } #ifdef MZ_USE_PLACES @@ -86,6 +94,21 @@ typedef struct Place_Start_Data { mzrt_sema *ready; } Place_Start_Data; +static Scheme_Object *def_place_exit_handler_proc(int argc, Scheme_Object *argv[]) +{ + long status; + + if (SCHEME_INTP(argv[0])) { + status = SCHEME_INT_VAL(argv[0]); + if (status < 1 || status > 255) + status = 0; + } else + status = 0; + + mz_proc_thread_exit((void *) status); + return scheme_void; /* Never get here */ +} + static void null_out_runtime_globals() { scheme_current_thread = NULL; scheme_first_thread = NULL; @@ -155,7 +178,7 @@ Scheme_Object *scheme_place(int argc, Scheme_Object *args[]) { return (Scheme_Object*) place; } -#ifdef MZ_PRECISE_GC +# ifdef MZ_PRECISE_GC /*============= SIGNAL HANDLER =============*/ #include #include @@ -324,13 +347,13 @@ static int place_wait_ready(Scheme_Object *o) { } return 0; } -#endif +# endif static Scheme_Object *scheme_place_wait(int argc, Scheme_Object *args[]) { Scheme_Place *place; place = (Scheme_Place *) args[0]; -#ifdef MZ_PRECISE_GC +# ifdef MZ_PRECISE_GC { Scheme_Object *rc; mz_proc_thread *worker_thread; @@ -353,13 +376,13 @@ static Scheme_Object *scheme_place_wait(int argc, Scheme_Object *args[]) { free(wd); return rc; } -#else +# else { void *rcvoid; rcvoid = mz_proc_thread_wait((mz_proc_thread *)place->proc_thread); return scheme_make_integer((long) rcvoid); } -#endif +# endif } static Scheme_Object *scheme_place_p(int argc, Scheme_Object *args[]) @@ -447,6 +470,8 @@ static void *place_start_proc(void *data_arg) { /* at point point, don't refer to place_data or its content anymore, because it's allocated in the other place */ + scheme_set_root_param(MZCONFIG_EXIT_HANDLER, scheme_def_place_exit_proc); + { Scheme_Thread * volatile p; mz_jmp_buf * volatile saved_error_buf; @@ -473,11 +498,11 @@ static void *place_start_proc(void *data_arg) { } Scheme_Object *scheme_places_deep_copy_in_master(Scheme_Object *so) { -#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) +# if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) void *return_payload; return_payload = scheme_master_fast_path(5, so); return (Scheme_Object*) return_payload; -#endif +# endif return so; } @@ -503,9 +528,7 @@ Scheme_Object *scheme_place_recv(int argc, Scheme_Object *args[]) { return scheme_true; } -#ifdef MZ_PRECISE_GC -static void* scheme_master_place_handlemsg(int msg_type, void *msg_payload); - +# ifdef MZ_PRECISE_GC static void* scheme_master_place_handlemsg(int msg_type, void *msg_payload) { switch(msg_type) { @@ -542,13 +565,13 @@ void* scheme_master_fast_path(int msg_type, void *msg_payload) { Scheme_Object *o; void *original_gc; -#ifdef MZ_PRECISE_GC +# ifdef MZ_PRECISE_GC original_gc = GC_switch_to_master_gc(); -#endif +# endif o = scheme_master_place_handlemsg(msg_type, msg_payload); -#ifdef MZ_PRECISE_GC +# ifdef MZ_PRECISE_GC GC_switch_back_from_master(original_gc); -#endif +# endif return o; } @@ -562,8 +585,7 @@ void scheme_spawn_master_place() { scheme_master_proc_thread = (void*) ~0; } - -#endif +# endif /*========================================================================*/ /* places async channels */ @@ -600,6 +622,12 @@ Scheme_Object *scheme_place_async_channel_create() { return (Scheme_Object *)ch; } +static Scheme_Object *scheme_place_ch_p(int argc, Scheme_Object *args[]) +{ + return SAME_TYPE(SCHEME_TYPE(args[0]), scheme_place_async_channel_type) ? scheme_true : scheme_false; +} + + void scheme_place_async_send(Scheme_Place_Async_Channel *ch, Scheme_Object *o) { int cnt; mzrt_mutex_lock(ch->lock); @@ -657,7 +685,6 @@ Scheme_Object *scheme_place_async_recv(Scheme_Place_Async_Channel *ch) { return msg; } - /*========================================================================*/ /* precise GC traversers */ /*========================================================================*/ diff --git a/src/mzscheme/src/portfun.c b/src/mzscheme/src/portfun.c index 19b3d81d90..3aa208d11d 100644 --- a/src/mzscheme/src/portfun.c +++ b/src/mzscheme/src/portfun.c @@ -769,22 +769,17 @@ static long user_read_result(const char *who, Scheme_Input_Port *port, "returned #f when no progress evt was supplied: ", val); return 0; - } else if (SCHEME_PROCP(val)) { - Scheme_Object *orig = val; - a[0] = val; - if (scheme_check_proc_arity(NULL, 4, 0, 1, a)) { - if (!special_ok) { - scheme_arg_mismatch(who, - "the port has no specific peek procedure, so" - " a special read result is not allowed: ", - orig); - return 0; - } - port->special = a[0]; - return SCHEME_SPECIAL; - } else - val = NULL; - n = 0; + } else if (SCHEME_PROCP(val) + && scheme_check_proc_arity(NULL, 4, 0, 1, a)) { + if (!special_ok) { + scheme_arg_mismatch(who, + "the port has no specific peek procedure, so" + " a special read result is not allowed: ", + val); + return 0; + } + port->special = val; + return SCHEME_SPECIAL; } else if (evt_ok && pipe_input_p(val)) { ((User_Input_Port *)port->port_data)->prefix_pipe = val; return 0; diff --git a/src/mzscheme/src/read.c b/src/mzscheme/src/read.c index e28db07262..e7b2fff578 100644 --- a/src/mzscheme/src/read.c +++ b/src/mzscheme/src/read.c @@ -4705,6 +4705,8 @@ static Scheme_Object *read_compact(CPort *port, int use_stack) break; case CPT_STX: { + Scheme_Hash_Table *save_ht; + if (!port->ut) { Scheme_Unmarshal_Tables *ut; Scheme_Hash_Table *rht; @@ -4725,8 +4727,8 @@ static Scheme_Object *read_compact(CPort *port, int use_stack) port->ut->rns = rht; } - if (*port->ht) - scheme_ill_formed_code(port); + save_ht = *port->ht; + *port->ht = NULL; v = read_compact(port, 1); @@ -4738,6 +4740,8 @@ static Scheme_Object *read_compact(CPort *port, int use_stack) 0, 0); } + *port->ht = save_ht; + v = scheme_unmarshal_datum_to_syntax(v, port->ut, 0); scheme_num_read_syntax_objects++; if (!v) diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 661b4f4709..3bfa135d30 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -238,7 +238,8 @@ void scheme_init_salloc(void); void scheme_init_jit(void); #endif void scheme_init_memtrace(Scheme_Env *env); -void scheme_init_parameterization(Scheme_Env *env); +void scheme_init_paramz(Scheme_Env *env); +void scheme_init_parameterization(); void scheme_init_getenv(void); void scheme_init_inspector(void); @@ -403,6 +404,14 @@ THREAD_LOCAL_DECL(extern volatile int scheme_fuel_counter); THREAD_LOCAL_DECL(extern Scheme_Thread *scheme_main_thread); +#if defined(MZ_USE_PLACES) || defined(MZ_USE_FUTURES) +# define MZ_USE_MZRT +#endif + +#ifdef MZ_USE_MZRT +#include "mzrt.h" +#endif + #ifdef MZ_USE_PLACES THREAD_LOCAL_DECL(extern Scheme_Thread *scheme_current_thread); THREAD_LOCAL_DECL(extern Scheme_Thread *scheme_first_thread); @@ -415,7 +424,6 @@ THREAD_LOCAL_DECL(extern Scheme_Thread *scheme_first_thread); #define scheme_jumping_to_continuation (scheme_current_thread->cjs.jumping_to_continuation) #define scheme_multiple_count (scheme_current_thread->ku.multiple.count) #define scheme_multiple_array (scheme_current_thread->ku.multiple.array) -#include "mzrt.h" extern mz_proc_thread *scheme_master_proc_thread; THREAD_LOCAL_DECL(extern mz_proc_thread *proc_thread_self); #endif @@ -2584,7 +2592,8 @@ void scheme_shadow(Scheme_Env *env, Scheme_Object *n, int stxtoo); int scheme_prefix_depth(Resolve_Prefix *rp); Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp, Scheme_Object *src_modix, Scheme_Object *now_modix, - int src_phase, int now_phase); + int src_phase, int now_phase, + Scheme_Env *dummy_env); void scheme_pop_prefix(Scheme_Object **rs); Scheme_Object *scheme_eval_clone(Scheme_Object *expr); diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index 8c43150e18..8881496a34 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "4.2.3.12" +#define MZSCHEME_VERSION "4.2.4.1" #define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_Y 2 -#define MZSCHEME_VERSION_Z 3 -#define MZSCHEME_VERSION_W 12 +#define MZSCHEME_VERSION_Z 4 +#define MZSCHEME_VERSION_W 1 #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/sstoinc.ss b/src/mzscheme/src/sstoinc.ss index 15dacd12a3..d29cb79c92 100644 --- a/src/mzscheme/src/sstoinc.ss +++ b/src/mzscheme/src/sstoinc.ss @@ -7,6 +7,9 @@ (namespace-require ''#%kernel) +(call-with-output-file (vector-ref (current-command-line-arguments) 0) #:exists 'replace + (lambda (outfile) + (let loop () (let ([expr (read)]) (unless (eof-object? expr) @@ -14,17 +17,17 @@ [p (open-output-bytes)]) (write c p) (let ([s (get-output-bytes p)]) - (printf " {~n SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {") + (fprintf outfile " {~n SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {") (let loop ([chars (bytes->list s)][pos 0]) (unless (null? chars) (let ([char (car chars)]) - (printf "~a," char)) + (fprintf outfile "~a," char)) (loop (cdr chars) (if (= pos DIGS-PER-LINE) (begin - (newline) + (newline outfile) 0) (add1 pos))))) - (printf "0};~n EVAL_ONE_SIZED_STR((char *)expr, ~a);~n" (bytes-length s)) - (printf " }~n"))) - (loop)))) + (fprintf outfile "0};~n EVAL_ONE_SIZED_STR((char *)expr, ~a);~n" (bytes-length s)) + (fprintf outfile " }~n"))) + (loop)))))) diff --git a/src/mzscheme/src/string.c b/src/mzscheme/src/string.c index d3db745161..6f314d8bba 100644 --- a/src/mzscheme/src/string.c +++ b/src/mzscheme/src/string.c @@ -163,9 +163,11 @@ typedef struct Scheme_Converter { may have changed. Similarly, setlocale() is only up-to-date when reset_locale() has been called. */ THREAD_LOCAL_DECL(static int locale_on); -THREAD_LOCAL_DECL(static const mzchar *current_locale_name); +THREAD_LOCAL_DECL(static void *current_locale_name_ptr); static void reset_locale(void); +#define current_locale_name ((const mzchar *)current_locale_name_ptr) + #ifdef USE_ICONV_DLL static char *nl_langinfo(int which) { @@ -173,7 +175,7 @@ static char *nl_langinfo(int which) reset_locale(); if (!current_locale_name) - current_locale_name = (mzchar *)"\0\0\0\0"; + current_locale_name_ptr ="\0\0\0\0"; if ((current_locale_name[0] == 'C') && !current_locale_name[1]) @@ -853,8 +855,8 @@ scheme_init_string (Scheme_Env *env) } void scheme_init_string_places(void) { - REGISTER_SO(current_locale_name); - current_locale_name = (mzchar *)"xxxx\0\0\0\0"; + REGISTER_SO(current_locale_name_ptr); + current_locale_name_ptr = "xxxx\0\0\0\0"; } /**********************************************************************/ @@ -3418,7 +3420,7 @@ static void reset_locale(void) setlocale(LC_COLLATE, "C"); } #endif - current_locale_name = name; + current_locale_name_ptr = (void *)name; } } diff --git a/src/mzscheme/src/struct.c b/src/mzscheme/src/struct.c index 876102c473..72fcd4835d 100644 --- a/src/mzscheme/src/struct.c +++ b/src/mzscheme/src/struct.c @@ -285,6 +285,10 @@ scheme_init_struct (Scheme_Env *env) (Scheme_Ready_Fun)evt_struct_is_ready, NULL, is_evt_struct, 1); + scheme_add_evt(scheme_proc_struct_type, + (Scheme_Ready_Fun)evt_struct_is_ready, + NULL, + is_evt_struct, 1); } { @@ -1055,6 +1059,11 @@ static Scheme_Object *check_evt_property_value_ok(int argc, Scheme_Object *argv[ return v; } +static Scheme_Object *return_wrapped(void *data, int argc, Scheme_Object *argv[]) +{ + return (Scheme_Object *)data; +} + static int evt_struct_is_ready(Scheme_Object *o, Scheme_Schedule_Info *sinfo) { Scheme_Object *v; @@ -1099,7 +1108,12 @@ static int evt_struct_is_ready(Scheme_Object *o, Scheme_Schedule_Info *sinfo) return 0; } - /* non-evt => ready and result is self */ + /* non-evt => ready and result is self; if self is a procedure, + we need to wrap it, so that self is not treated as a `wrap-evt' + procedure. */ + if (SCHEME_PROCP(o)) { + o = scheme_make_closed_prim_w_arity(return_wrapped, (void *)o, "wrapper", 1, 1); + } scheme_set_sync_target(sinfo, o, o, NULL, 0, 0, NULL); return 1; diff --git a/src/mzscheme/src/syntax.c b/src/mzscheme/src/syntax.c index e401745dd1..53f4c9f491 100644 --- a/src/mzscheme/src/syntax.c +++ b/src/mzscheme/src/syntax.c @@ -700,7 +700,7 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro, if (dm_env) { scheme_prepare_exp_env(dm_env); - save_runstack = scheme_push_prefix(dm_env->exp_env, rp, NULL, NULL, 1, 1); + save_runstack = scheme_push_prefix(dm_env->exp_env, rp, NULL, NULL, 1, 1, NULL); vals = scheme_eval_linked_expr_multi_with_dynamic_state(vals_expr, dyn_state); if (defmacro == 2) dm_env = NULL; @@ -5850,7 +5850,7 @@ static Scheme_Object *eval_letmacro_rhs(Scheme_Object *a, Scheme_Comp_Env *rhs_e return (Scheme_Object *)scheme_enlarge_runstack(depth, eval_letmacro_rhs_k); } - save_runstack = scheme_push_prefix(NULL, rp, NULL, NULL, phase, phase); + save_runstack = scheme_push_prefix(NULL, rp, NULL, NULL, phase, phase, rhs_env->genv); if (scheme_omittable_expr(a, 1, -1, 0, NULL)) { /* short cut */ diff --git a/src/mzscheme/src/thread.c b/src/mzscheme/src/thread.c index 50376edce3..69ff301437 100644 --- a/src/mzscheme/src/thread.c +++ b/src/mzscheme/src/thread.c @@ -41,7 +41,7 @@ #include "schpriv.h" #include "schmach.h" #include "schgc.h" -#ifdef FUTURES_ENABLED +#ifdef MZ_USE_FUTURES # include "future.h" #endif #ifndef PALMOS_STUFF @@ -232,7 +232,6 @@ THREAD_LOCAL_DECL(static Scheme_Object *thread_swap_out_callbacks); THREAD_LOCAL_DECL(static Scheme_Object *recycle_cell); THREAD_LOCAL_DECL(static Scheme_Object *maybe_recycle_cell); THREAD_LOCAL_DECL(static int recycle_cc_count); -THREAD_LOCAL_DECL(static mz_jmp_buf main_init_error_buf); #ifdef MZ_PRECISE_GC extern long GC_get_memory_use(void *c); @@ -851,17 +850,20 @@ Scheme_Object *scheme_get_current_inspector() return scheme_get_param(c, MZCONFIG_INSPECTOR); } -void scheme_init_parameterization(Scheme_Env *env) +void scheme_init_parameterization() { - Scheme_Object *v; - Scheme_Env *newenv; - REGISTER_SO(scheme_exn_handler_key); REGISTER_SO(scheme_parameterization_key); REGISTER_SO(scheme_break_enabled_key); scheme_exn_handler_key = scheme_make_symbol("exnh"); scheme_parameterization_key = scheme_make_symbol("paramz"); scheme_break_enabled_key = scheme_make_symbol("break-on?"); +} + +void scheme_init_paramz(Scheme_Env *env) +{ + Scheme_Object *v; + Scheme_Env *newenv; v = scheme_intern_symbol("#%paramz"); newenv = scheme_primitive_module(v, env); @@ -2199,7 +2201,7 @@ static Scheme_Thread *make_thread(Scheme_Config *config, process->suspend_break = 1; /* until start-up finished */ - process->error_buf = &main_init_error_buf; + process->error_buf = NULL; thread_swap_callbacks = scheme_null; thread_swap_out_callbacks = scheme_null; @@ -2296,6 +2298,9 @@ static Scheme_Thread *make_thread(Scheme_Config *config, scheme_first_thread = process; } + if (!buffer_init_size) /* => before place init */ + buffer_init_size = INIT_TB_SIZE; + { Scheme_Object **tb; tb = MALLOC_N(Scheme_Object *, buffer_init_size); @@ -4127,7 +4132,7 @@ void scheme_thread_block(float sleep_time) /* Check scheduled_kills early and often. */ check_scheduled_kills(); -#ifdef FUTURES_ENABLED +#ifdef MZ_USE_FUTURES scheme_check_future_work(); #endif @@ -5878,7 +5883,7 @@ static Scheme_Object *do_sync(const char *name, int argc, Scheme_Object *argv[], if (syncing->result) { /* Apply wrap functions to the selected evt: */ Scheme_Object *o, *l, *a, *to_call = NULL, *args[1]; - int to_call_is_cont = 0; + int to_call_is_handle = 0; o = evt_set->argv[syncing->result - 1]; if (SAME_TYPE(SCHEME_TYPE(o), scheme_channel_syncer_type)) { @@ -5905,7 +5910,7 @@ static Scheme_Object *do_sync(const char *name, int argc, Scheme_Object *argv[], if (SCHEME_BOXP(a) || SCHEME_PROCP(a)) { if (SCHEME_BOXP(a)) { a = SCHEME_BOX_VAL(a); - to_call_is_cont = 1; + to_call_is_handle = 1; } to_call = a; } else if (SAME_TYPE(scheme_thread_suspend_type, SCHEME_TYPE(a)) @@ -5918,9 +5923,9 @@ static Scheme_Object *do_sync(const char *name, int argc, Scheme_Object *argv[], if (to_call) { args[0] = o; - /* If to_call is still a wrap-evt (not a cont-evt), + /* If to_call is still a wrap-evt (not a handle-evt), then set the config one more time: */ - if (!to_call_is_cont) { + if (!to_call_is_handle) { scheme_push_break_enable(&cframe, 0, 0); tailok = 0; } @@ -5929,7 +5934,7 @@ static Scheme_Object *do_sync(const char *name, int argc, Scheme_Object *argv[], return _scheme_tail_apply(to_call, 1, args); } else { o = scheme_apply(to_call, 1, args); - if (!to_call_is_cont) + if (!to_call_is_handle) scheme_pop_break_enable(&cframe, 1); return o; } @@ -7346,7 +7351,7 @@ static void get_ready_for_GC() { start_this_gc_time = scheme_get_process_milliseconds(); -#ifdef FUTURES_ENABLED +#ifdef MZ_USE_FUTURES scheme_future_block_until_gc(); #endif @@ -7418,7 +7423,7 @@ static void done_with_GC() end_this_gc_time = scheme_get_process_milliseconds(); scheme_total_gc_time += (end_this_gc_time - start_this_gc_time); -#ifdef FUTURES_ENABLED +#ifdef MZ_USE_FUTURES scheme_future_continue_after_gc(); #endif } diff --git a/src/worksp/mred/mred.manifest b/src/worksp/mred/mred.manifest index 0535c75591..6626ef2caf 100644 --- a/src/worksp/mred/mred.manifest +++ b/src/worksp/mred/mred.manifest @@ -1,7 +1,7 @@ Number(); - if (0 <= N && N < numberItems) { + if (-1 <= N && N < numberItems) { if (selected != N) { if (0 <= selected && selected < numberItems) { selectedNode = cRadioButtons->Nth(selected); @@ -290,9 +290,11 @@ void wxRadioBox::SetSelection(int N) selectedRadioButton->SetValue(FALSE); } - node = cRadioButtons->Nth(N); - radioButton = (wxRadioButton*)node->Data(); - radioButton->SetValue(TRUE); + if (N != -1) { + node = cRadioButtons->Nth(N); + radioButton = (wxRadioButton*)node->Data(); + radioButton->SetValue(TRUE); + } selected = N; } diff --git a/src/wxwindow/src/msw/wx_rbox.cxx b/src/wxwindow/src/msw/wx_rbox.cxx index 1db07f443b..aa312f6f07 100644 --- a/src/wxwindow/src/msw/wx_rbox.cxx +++ b/src/wxwindow/src/msw/wx_rbox.cxx @@ -424,7 +424,7 @@ void wxRadioBox::SetButton(int which, int value) void wxRadioBox::SetSelection(int N) { - if ((N < 0) || (N >= no_items)) + if ((N < -1) || (N >= no_items)) return; if (N == selected) @@ -433,7 +433,8 @@ void wxRadioBox::SetSelection(int N) if (selected >= 0 && selected < no_items) SetButton(selected, 0); - SetButton(N, 1); + if (N != -1) + SetButton(N, 1); selected = N; } diff --git a/src/wxxt/src/Windows/RadioBox.cc b/src/wxxt/src/Windows/RadioBox.cc index ff64a1ef26..cdd6285129 100644 --- a/src/wxxt/src/Windows/RadioBox.cc +++ b/src/wxxt/src/Windows/RadioBox.cc @@ -134,8 +134,7 @@ Bool wxRadioBox::Create(wxPanel *panel, wxFunction func, char *label, X->frame = wgt; // create group widget, which holds the toggles wgt = XtVaCreateManagedWidget("radiobox", xfwfGroupWidgetClass, X->frame, - XtNselectionStyle, (style & wxAT_MOST_ONE) ? - XfwfSingleSelection : XfwfOneSelection, + XtNselectionStyle, XfwfSingleSelection, XtNstoreByRow, FALSE, XtNlabel, NULL, XtNframeWidth, 0, @@ -265,8 +264,7 @@ Bool wxRadioBox::Create(wxPanel *panel, wxFunction func, char *label, // create group widget, which holds the toggles wgt = XtVaCreateManagedWidget("radiobox", xfwfGroupWidgetClass, X->frame, - XtNselectionStyle, (style & wxAT_MOST_ONE) ? - XfwfSingleSelection : XfwfOneSelection, + XtNselectionStyle, XfwfSingleSelection, XtNstoreByRow, FALSE, XtNlabel, NULL, XtNframeWidth, 0, @@ -518,7 +516,7 @@ void wxRadioBox::SetLabel(int item, wxBitmap *bitmap) void wxRadioBox::SetSelection(int item) { - if (0 <= item && item < num_toggles) + if (-1 <= item && item < num_toggles) XtVaSetValues(X->handle, XtNselection, (long)item, NULL); }