diff --git a/collects/browser/browser.scrbl b/collects/browser/browser.scrbl index 5a9df3288a..4a1032c9b2 100644 --- a/collects/browser/browser.scrbl +++ b/collects/browser/browser.scrbl @@ -8,6 +8,7 @@ browser/external browser/tool scheme/base + scheme/contract scheme/class scheme/gui/base net/url @@ -26,8 +27,8 @@ The @schememodname[browser] library provides the following procedures and classes for parsing and viewing HTML files. The @schememodname[browser/htmltext] library provides a simplified interface for rendering to a subclass of the MrEd @scheme[text%] -class. The [browser/external] library provides utilities for launching -an external browser (such as Firefox). +class. The @schememodname[browser/external] library provides utilities +for launching an external browser (such as Firefox). @section[#:tag "browser"]{Browser} @@ -80,7 +81,7 @@ examples). The Scheme code is executed through @scheme[eval]. The @(litchar "MZSCHEME") forms are disabled unless the web page is a @(litchar "file:") url that points into the @scheme[doc] collection. -@defproc[(open-url [url (or/c url? string? input-port?)]) void?]{ +@defproc[(open-url [url (or/c url? string? input-port?)]) (is-a?/c hyper-frame%)]{ Opens the given url in a vanilla browser frame and returns the frame. The frame is an instance of @@ -534,7 +535,6 @@ library.} Extends the given @scheme[text%] class with implementations of the @scheme[html-text<%>] methods. Hyperlinks are attached to clickbacks that use @net-send-url from @schememodname[net/sendurl]. - } } @defproc[(render-html-to-text [in input-port?] diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index b4d4375997..6660c45300 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -220,14 +220,14 @@ (match v [`(,name ,self-modidx ,lang-info ,functional? ,et-functional? ,rename ,max-let-depth ,dummy - ,prefix ,kernel-exclusion ,reprovide-kernel? + ,prefix ,indirect-provides ,num-indirect-provides ,indirect-syntax-provides ,num-indirect-syntax-provides ,indirect-et-provides ,num-indirect-et-provides ,protects ,et-protects ,provide-phase-count . ,rest) - (let ([phase-data (take rest (* 8 provide-phase-count))]) - (match (list-tail rest (* 8 provide-phase-count)) + (let ([phase-data (take rest (* 9 provide-phase-count))]) + (match (list-tail rest (* 9 provide-phase-count)) [`(,syntax-body ,body ,requires ,syntax-requires ,template-requires ,label-requires ,more-requires-count . ,more-requires) @@ -729,7 +729,7 @@ [read-accept-dot #t] [read-accept-infix-dot #t] [read-accept-quasiquote #t]) - (read (open-input-bytes s))))] + (read/recursive (open-input-bytes s))))] [(reference) (make-primval (read-compact-number cp))] [(small-list small-proper-list) @@ -837,7 +837,17 @@ [(box) (box (read-compact cp))] [(quote) - (make-reader-graph (read-compact cp))] + (make-reader-graph + ;; Nested escapes need to share graph references. So get inside the + ;; read where `read/recursive' can be used: + (let ([rt (current-readtable)]) + (parameterize ([current-readtable (make-readtable + #f + #\x 'terminating-macro + (lambda args + (parameterize ([current-readtable rt]) + (read-compact cp))))]) + (read (open-input-bytes #"x")))))] [(symref) (let* ([l (read-compact-number cp)] [v (vector-ref (cport-symtab cp) l)]) diff --git a/collects/drscheme/private/main.ss b/collects/drscheme/private/main.ss index 9068fe5f89..5748249977 100644 --- a/collects/drscheme/private/main.ss +++ b/collects/drscheme/private/main.ss @@ -226,6 +226,7 @@ null list?) + (drscheme:font:setup-preferences) (color-prefs:add-background-preferences-panel) (scheme:add-preferences-panel) @@ -233,6 +234,7 @@ (preferences:add-editor-checkbox-panel) (preferences:add-warnings-checkbox-panel) (preferences:add-scheme-checkbox-panel) +(preferences:add-general-checkbox-panel) (let ([make-check-box (λ (pref-sym string parent) @@ -245,7 +247,7 @@ (send checkbox get-value))))]) (preferences:add-callback pref-sym (λ (p v) (send q set-value v))) (send q set-value (preferences:get pref-sym))))]) - (preferences:add-to-editor-checkbox-panel + (preferences:add-to-general-checkbox-panel (λ (editor-panel) (make-check-box 'drscheme:open-in-tabs (string-constant open-files-in-tabs) @@ -264,7 +266,11 @@ (make-check-box 'drscheme:module-language-first-line-special? (string-constant ml-always-show-#lang-line) - editor-panel) + editor-panel))) + + (preferences:add-to-editor-checkbox-panel + (λ (editor-panel) + (void) ;; come back to this one. #; diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss index 96bd20a34b..6a8dd409c9 100644 --- a/collects/drscheme/private/rep.ss +++ b/collects/drscheme/private/rep.ss @@ -84,8 +84,7 @@ TODO text:ports<%> editor:file<%> scheme:text<%> - color:text<%> - text:ports<%>) + color:text<%>) reset-highlighting highlight-errors highlight-errors/exn diff --git a/collects/framework/main.ss b/collects/framework/main.ss index 0f16c0fc9d..c85f5de883 100644 --- a/collects/framework/main.ss +++ b/collects/framework/main.ss @@ -198,6 +198,12 @@ @{Adds a preferences panel for configuring options related to editing.}) + (proc-doc/names + preferences:add-general-checkbox-panel + (-> void?) + () + @{Adds a catch-all preferences panel for options.}) + (proc-doc/names preferences:add-warnings-checkbox-panel (-> void?) @@ -232,7 +238,15 @@ (((is-a?/c vertical-panel%) . -> . void?) . -> . void?) (proc) @{Saves @scheme[proc] until the preferences panel is created, when it - is called with the Echeme preferences panel to add new children to + is called with the editor preferences panel to add new children to + the panel.}) + + (proc-doc/names + preferences:add-to-general-checkbox-panel + (((is-a?/c vertical-panel%) . -> . void?) . -> . void?) + (proc) + @{Saves @scheme[proc] until the preferences panel is created, when it + is called with the general preferences panel to add new children to the panel.}) (proc-doc/names diff --git a/collects/framework/private/color.ss b/collects/framework/private/color.ss index 80b64bd42d..a5b0526bbb 100644 --- a/collects/framework/private/color.ss +++ b/collects/framework/private/color.ss @@ -260,7 +260,11 @@ added get-regions (define/private (re-tokenize ls in in-start-pos enable-suspend) (let-values ([(lexeme type data new-token-start new-token-end) - (get-token in)]) + (begin + (enable-suspend #f) + (begin0 + (get-token in) + (enable-suspend #t)))]) (unless (eq? 'eof type) (enable-suspend #f) #; (printf "~a at ~a to ~a~n" lexeme (+ in-start-pos (sub1 new-token-start)) @@ -365,10 +369,14 @@ added get-regions (for-each (lambda (ls) (re-tokenize ls - (open-input-text-editor this - (lexer-state-current-pos ls) - (lexer-state-end-pos ls) - (λ (x) #f)) + (begin + (enable-suspend #f) + (begin0 + (open-input-text-editor this + (lexer-state-current-pos ls) + (lexer-state-end-pos ls) + (λ (x) #f)) + (enable-suspend #t))) (lexer-state-current-pos ls) enable-suspend)) lexer-states))))) diff --git a/collects/framework/private/decorated-editor-snip.ss b/collects/framework/private/decorated-editor-snip.ss index f495ee35a6..969e76c446 100644 --- a/collects/framework/private/decorated-editor-snip.ss +++ b/collects/framework/private/decorated-editor-snip.ss @@ -22,6 +22,9 @@ (define editor-snip:decorated-mixin (mixin ((class->interface editor-snip%)) (editor-snip:decorated<%>) + (init [with-border? #t]) + (define draw-border? with-border?) + ;; get-corner-bitmap : -> (union #f (is-a?/c bitmap%)) ;; returns the bitmap to be shown in the top right corner. (define/public (get-corner-bitmap) #f) @@ -152,13 +155,14 @@ (+ x (unbox bil) 2) (+ y (unbox bmt)))]))) - (send dc set-pen (get-pen)) - (send dc set-brush (get-brush)) - (send dc draw-rectangle - (+ x (unbox bil)) - (+ y (unbox bit)) - (max 0 (- (unbox bw) (unbox bil) (unbox bir))) - (max 0 (- (unbox bh) (unbox bit) (unbox bib)))) + (when draw-border? + (send dc set-pen (get-pen)) + (send dc set-brush (get-brush)) + (send dc draw-rectangle + (+ x (unbox bil)) + (+ y (unbox bit)) + (max 0 (- (unbox bw) (unbox bil) (unbox bir))) + (max 0 (- (unbox bh) (unbox bit) (unbox bib))))) (send dc set-pen old-pen) (send dc set-brush old-brush)))) diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index b07f779714..e1db4bb9ab 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -2096,17 +2096,14 @@ (send (send find-edit get-canvas) focus)))) (define/public (unhide-search-and-toggle-focus) - (cond - [hidden? - (unhide-search #t)] - [(or (not text-to-search) - (send (send text-to-search get-canvas) has-focus?)) - (send find-edit set-position 0 (send find-edit last-position)) - (send find-canvas focus)] - [else - (let ([canvas (send text-to-search get-canvas)]) - (when canvas - (send canvas focus)))])) + (if hidden? + (unhide-search #t) + (let ([canvas (and text-to-search (send text-to-search get-canvas))]) + (cond + [(or (not text-to-search) (and canvas (send canvas has-focus?))) + (send find-edit set-position 0 (send find-edit last-position)) + (send find-canvas focus)] + [canvas (send canvas focus)])))) (define/public (search searching-direction) (unhide-search #f) diff --git a/collects/framework/private/preferences.ss b/collects/framework/private/preferences.ss index 5bb3db1dde..c2a10f4065 100644 --- a/collects/framework/private/preferences.ss +++ b/collects/framework/private/preferences.ss @@ -227,8 +227,9 @@ the state transitions / contracts are: (super show on?)) (super-new))] [frame - (make-object frame-stashed-prefs% - (string-constant preferences))] + (new frame-stashed-prefs% + [label (string-constant preferences)] + [height 200])] [build-ppanel-tree (λ (ppanel tab-panel single-panel) (send tab-panel append (ppanel-name ppanel)) @@ -310,6 +311,11 @@ the state transitions / contracts are: (let ([old editor-panel-procs]) (λ (parent) (old parent) (f parent))))) + (define (add-to-general-checkbox-panel f) + (set! general-panel-procs + (let ([old general-panel-procs]) + (λ (parent) (old parent) (f parent))))) + (define (add-to-warnings-checkbox-panel f) (set! warnings-panel-procs (let ([old warnings-panel-procs]) @@ -317,6 +323,7 @@ the state transitions / contracts are: (define scheme-panel-procs void) (define editor-panel-procs void) + (define general-panel-procs void) (define warnings-panel-procs void) (define (add-checkbox-panel label proc) @@ -394,21 +401,8 @@ the state transitions / contracts are: (list (string-constant editor-prefs-panel-label) (string-constant general-prefs-panel-label)) (λ (editor-panel) - (make-recent-items-slider editor-panel) - (make-check editor-panel - 'framework:autosaving-on? - (string-constant auto-save-files) - values values) - (make-check editor-panel 'framework:backup-files? (string-constant backup-files) values values) (make-check editor-panel 'framework:delete-forward? (string-constant map-delete-to-backspace) not not) - (make-check editor-panel 'framework:show-status-line (string-constant show-status-line) values values) - (make-check editor-panel 'framework:col-offsets (string-constant count-columns-from-one) values values) - (make-check editor-panel - 'framework:display-line-numbers - (string-constant display-line-numbers) - values values) - (make-check editor-panel 'framework:auto-set-wrap? (string-constant wrap-words-in-editor-buffers) @@ -432,13 +426,7 @@ the state transitions / contracts are: 'framework:coloring-active (string-constant online-coloring-active) values values) - (unless (eq? (system-type) 'unix) - (make-check editor-panel - 'framework:print-output-mode - (string-constant automatically-to-ps) - (λ (b) - (if b 'postscript 'standard)) - (λ (n) (eq? 'postscript n)))) + (make-check editor-panel 'framework:anchored-search (string-constant find-anchor-based) @@ -454,6 +442,34 @@ the state transitions / contracts are: (editor-panel-procs editor-panel))))]) (add-editor-checkbox-panel))) + (define (add-general-checkbox-panel) + (letrec ([add-general-checkbox-panel + (λ () + (set! add-general-checkbox-panel void) + (add-checkbox-panel + (list (string-constant general-prefs-panel-label)) + (λ (editor-panel) + (make-recent-items-slider editor-panel) + (make-check editor-panel + 'framework:autosaving-on? + (string-constant auto-save-files) + values values) + (make-check editor-panel 'framework:backup-files? (string-constant backup-files) values values) + (make-check editor-panel 'framework:show-status-line (string-constant show-status-line) values values) + (make-check editor-panel 'framework:col-offsets (string-constant count-columns-from-one) values values) + (make-check editor-panel + 'framework:display-line-numbers + (string-constant display-line-numbers) + values values) + (unless (eq? (system-type) 'unix) + (make-check editor-panel + 'framework:print-output-mode + (string-constant automatically-to-ps) + (λ (b) + (if b 'postscript 'standard)) + (λ (n) (eq? 'postscript n)))))))]) + (add-general-checkbox-panel))) + (define (add-warnings-checkbox-panel) (letrec ([add-warnings-checkbox-panel (λ () diff --git a/collects/framework/private/sig.ss b/collects/framework/private/sig.ss index 32e5a03316..ec23b69f8f 100644 --- a/collects/framework/private/sig.ss +++ b/collects/framework/private/sig.ss @@ -74,10 +74,12 @@ add-font-panel add-editor-checkbox-panel + add-general-checkbox-panel add-warnings-checkbox-panel add-scheme-checkbox-panel add-to-editor-checkbox-panel + add-to-general-checkbox-panel add-to-warnings-checkbox-panel add-to-scheme-checkbox-panel diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index 63711e616a..391bf360b2 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -1170,7 +1170,11 @@ WARNING: printf is rebound in the body of the unit to always (set! clear-yellow void) (when (and searching-str (= (string-length searching-str) (- end start))) (when (do-search searching-str start end) - (set! clear-yellow (highlight-range start end "khaki" #f 'low 'ellipse)))) + (set! clear-yellow (highlight-range start end + (if (preferences:get 'framework:white-on-black?) + (make-object color% 50 50 5) + "khaki") + #f 'low 'ellipse)))) (end-edit-sequence)]))] [else (clear-yellow) diff --git a/collects/lang/htdp-advanced.ss b/collects/lang/htdp-advanced.ss index 1e2bad565f..b36a3e4d1c 100644 --- a/collects/lang/htdp-advanced.ss +++ b/collects/lang/htdp-advanced.ss @@ -16,6 +16,7 @@ [advanced-define define] [advanced-define-struct define-struct] [advanced-lambda lambda] + [advanced-lambda λ] [advanced-app #%app] [beginner-top #%top] [intermediate-local local] diff --git a/collects/lang/htdp-intermediate-lambda.ss b/collects/lang/htdp-intermediate-lambda.ss index b5be5e7a43..338a803f47 100644 --- a/collects/lang/htdp-intermediate-lambda.ss +++ b/collects/lang/htdp-intermediate-lambda.ss @@ -12,6 +12,7 @@ [intermediate-lambda-define define] [intermediate-define-struct define-struct] [intermediate-lambda lambda] + [intermediate-lambda λ] [advanced-app #%app] [beginner-top #%top] [intermediate-local local] diff --git a/collects/mred/mred.ss b/collects/mred/mred.ss index 0ba30ed867..de283d13ff 100644 --- a/collects/mred/mred.ss +++ b/collects/mred/mred.ss @@ -74,6 +74,11 @@ (namespace-require 'scheme/class)) ns)) + (define (make-eventspace) + (parameterize ([wx:the-snip-class-list (wx:make-the-snip-class-list)] + [wx:the-editor-data-class-list (wx:make-the-editor-data-class-list)]) + (wx:make-eventspace))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-syntax propagate @@ -139,7 +144,6 @@ is-color-display? key-event% keymap% - make-eventspace editor-admin% editor-set-x-selection-mode editor-snip-editor-admin<%> @@ -307,6 +311,7 @@ current-eventspace-has-standard-menus? current-eventspace-has-menu-root? eventspace-handler-thread + make-eventspace make-gui-namespace make-gui-empty-namespace file-creator-and-type diff --git a/collects/mred/private/wxme/cycle.ss b/collects/mred/private/wxme/cycle.ss index 7bc9556321..ee30467e8d 100644 --- a/collects/mred/private/wxme/cycle.ss +++ b/collects/mred/private/wxme/cycle.ss @@ -25,3 +25,5 @@ (decl editor-put-file set-editor-put-file!) (decl popup-menu% set-popup-menu%!) + + diff --git a/collects/mred/private/wxme/editor.ss b/collects/mred/private/wxme/editor.ss index 086ba4441a..8df9606949 100644 --- a/collects/mred/private/wxme/editor.ss +++ b/collects/mred/private/wxme/editor.ss @@ -611,11 +611,8 @@ (and ;; Read headers (for/and ([i (in-range num-headers)]) - (let-boxes ([n 0] - [len 0]) - (begin - (send f get n) - (send f get-fixed len)) + (let ([n (send f get-exact)] + [len (send f get-fixed-exact)]) (and (send f ok?) (or (zero? len) (let ([sclass (send (send f get-s-scl) find-by-map-position f n)]) @@ -646,11 +643,10 @@ (let ([sclass (if (n . >= . 0) (send (send f get-s-scl) find-by-map-position f n) #f)]) ; -1 => unknown - (let-boxes ([len 0]) - (if (or (not sclass) - (not (send sclass get-s-required?))) - (send f get-fixed len) - (set-box! len -1)) + (let ([len (if (or (not sclass) + (not (send sclass get-s-required?))) + (send f get-fixed-exact) + -1)]) (and (send f ok?) (or (and (zero? len) accum) (and @@ -658,8 +654,7 @@ (let ([start (send f tell)]) (when (len . >= . 0) (send f set-boundary len)) - (let-boxes ([style-index 0]) - (send f get style-index) + (let ([style-index (send f get-exact)]) (let ([snip (send sclass read f)]) (and snip @@ -1337,7 +1332,7 @@ (editor-get-file "choose a file" (extract-parent) #f path)) (def/public (put-file [(make-or-false path-string?) dir] - [(make-or-false string?) suggested-name]) + [(make-or-false path-string?) suggested-name]) (editor-put-file "save file as" (extract-parent) dir suggested-name)) (def/public (set-load-overwrites-styles [any? b?]) @@ -1419,7 +1414,7 @@ (let ([sclass (snip->snipclass snip)]) (unless sclass (error 'write-snips-to-file "snip has no snipclass")) - (if (send f do-get-header-flag sclass) + (if (not (send f do-get-header-flag sclass)) (begin (send f put (send f do-map-position sclass)) (let ([header-start (send f tell)]) diff --git a/collects/mred/private/wxme/pasteboard.ss b/collects/mred/private/wxme/pasteboard.ss index 80b023d942..9402788f45 100644 --- a/collects/mred/private/wxme/pasteboard.ss +++ b/collects/mred/private/wxme/pasteboard.ss @@ -1913,7 +1913,7 @@ (do-write-headers-footers f #f))) (def/override (read-from-file [editor-stream-in% f] - [bool? [overwritestyle? #t]]) + [bool? [overwritestyle? #f]]) (if (or s-user-locked? (not (zero? write-locked))) #f diff --git a/collects/mred/private/wxme/snip.ss b/collects/mred/private/wxme/snip.ss index 510e148d6a..22b4c0daf5 100644 --- a/collects/mred/private/wxme/snip.ss +++ b/collects/mred/private/wxme/snip.ss @@ -26,6 +26,11 @@ get-the-snip-class-list get-the-editor-data-class-list the-editor-snip-class + + the-snip-class-list ;; parameter + make-the-snip-class-list + the-editor-data-class-list ;; parameter + make-the-editor-data-class-list (struct-out snip-class-link) (struct-out editor-data-class-link) @@ -315,11 +320,9 @@ (s-read (make-object string-snip% 0) f)) (def/public (s-read [string-snip% snip] [editor-stream-in% f]) - (let-boxes ([flags 0]) - (send f get flags) + (let ([flags (send f get-exact)]) (let ([pos (send f tell)]) - (let-boxes ([count 0]) - (send f get count) + (let ([count (send f get-exact)]) (send f jump-to pos) (let ([count (if (count . < . 0) 10; this is a failure; we make up something @@ -1323,9 +1326,10 @@ (define (make-the-snip-class-list) (new standard-snip-class-list%)) -(define the-snip-class-list (make-the-snip-class-list)) +(define the-snip-class-list (make-parameter (make-the-snip-class-list))) + (define (get-the-snip-class-list) - the-snip-class-list) + (the-snip-class-list)) ;; ------------------------------------------------------------ @@ -1465,9 +1469,9 @@ (define (make-the-editor-data-class-list) (new editor-data-class-list%)) -(define the-editor-data-class-list (make-the-editor-data-class-list)) +(define the-editor-data-class-list (make-parameter (make-the-editor-data-class-list))) (define (get-the-editor-data-class-list) - the-editor-data-class-list) + (the-editor-data-class-list)) ;; ------------------------------------------------------------ diff --git a/collects/mred/private/wxme/stream.ss b/collects/mred/private/wxme/stream.ss index d5ed4bb417..85eb7d139a 100644 --- a/collects/mred/private/wxme/stream.ss +++ b/collects/mred/private/wxme/stream.ss @@ -99,7 +99,11 @@ (def/public (read-bytes [bytes? v] [exact-nonnegative-integer? [start 0]] [exact-nonnegative-integer? [end (bytes-length v)]]) - 0)) + 0) + (def/public (read-byte) + (let ([s (make-bytes 1)]) + (and (= 1 (read-bytes s 0 1)) + (bytes-ref s 0))))) (defclass editor-stream-out-base% object% (super-new) @@ -116,6 +120,8 @@ ;; ---------------------------------------- +(define mz:read-byte read-byte) + (defclass editor-stream-in-port-base% editor-stream-in-base% (init-field port) (super-new) @@ -137,7 +143,11 @@ (let ([r (read-bytes! v port start end)]) (if (eof-object? r) 0 - r)))) + r))) + + (def/override (read-byte) + (let ([v (mz:read-byte port)]) + (if (eof-object? v) #f v)))) (defclass editor-stream-in-file-base% editor-stream-in-port-base% (super-new)) @@ -182,6 +192,8 @@ ;; ---------------------------------------- +(define in-read-byte (generic editor-stream-in-base% read-byte)) + (defclass editor-stream-in% editor-stream% (init-rest args) @@ -216,48 +228,50 @@ (define (bad!) (set! is-bad? #t) 0) (if is-bad? 0 - (let ([s (make-bytes 1)]) - (let loop ([prev-byte 0]) - (if (not (= 1 (send f read-bytes s))) + (let loop ([prev-byte 0]) + (let ([b (send-generic f in-read-byte)]) + (if (not b) (bad!) - (let ([b (bytes-ref s 0)]) - (case (integer->char b) - [(#\#) - (let ([pos (send f tell)]) - (if (and (= 1 (send f read-bytes s)) - (= (bytes-ref s 0) (char->integer #\|))) - ;; skip to end of comment - (let cloop ([saw-bar? #f] - [saw-hash? #f] - [nesting 0]) - (if (not (= 1 (send f read-bytes s))) + (case (integer->char b) + [(#\#) + (let ([pos (send f tell)] + [b (send-generic f in-read-byte)]) + (if (and b + (= b (char->integer #\|))) + ;; skip to end of comment + (let cloop ([saw-bar? #f] + [saw-hash? #f] + [nesting 0]) + (let ([b (send-generic f in-read-byte)]) + (if (not b) (bad!) (cond - [(and saw-bar? (= (bytes-ref s 0) (char->integer #\#))) + [(and saw-bar? (= b (char->integer #\#))) (if (zero? nesting) (loop (char->integer #\space)) (cloop #f #f (sub1 nesting)))] - [(and saw-hash? (= (bytes-ref s 0) (char->integer #\|))) + [(and saw-hash? (= b (char->integer #\|))) (cloop #t #f (add1 nesting))] - [else (cloop (= (bytes-ref s 0) (char->integer #\|)) - (= (bytes-ref s 0) (char->integer #\#)) - nesting)]))) - (begin - (send f seek pos) - (char->integer #\#))))] - [(#\;) - ;; skip to end of comment - (let cloop () - (if (not (= 1 (send f read-bytes s))) + [else (cloop (= b (char->integer #\|)) + (= b (char->integer #\#)) + nesting)])))) + (begin + (send f seek pos) + (char->integer #\#))))] + [(#\;) + ;; skip to end of comment + (let cloop () + (let ([b (send-generic f in-read-byte)]) + (if (not b) (bad!) - (if (or (= (bytes-ref s 0) (char->integer #\newline)) - (= (bytes-ref s 0) (char->integer #\return))) + (if (or (= b (char->integer #\newline)) + (= b (char->integer #\return))) (loop (char->integer #\space)) - (cloop))))] - [else - (if (char-whitespace? (integer->char b)) - (loop b) - b)]))))))) + (cloop)))))] + [else + (if (char-whitespace? (integer->char b)) + (loop b) + b)])))))) (define/private (skip-whitespace [buf #f]) (let ([c (do-skip-whitespace)]) @@ -270,9 +284,8 @@ [(char-whitespace? (integer->char b)) #t] [(= b (char->integer #\#)) (let ([pos (send f tell)] - [s (make-bytes 1)]) - (send f read-bytes s) - (let ([d? (= (bytes-ref s 0) (char->integer #\|))]) + [b (send-generic f in-read-byte)]) + (let ([d? (= b (char->integer #\|))]) (send f seek (if d? (sub1 pos) pos)) d?))] [(= b (char->integer #\;)) @@ -284,36 +297,43 @@ (let ([c0 (skip-whitespace)]) (if (check-boundary) (if get-exact? 0 0.0) - (let* ([s (make-bytes 1)] - [l (cons (integer->char c0) - (let loop ([counter 50]) - (if (zero? counter) - null - (if (= 1 (send f read-bytes s)) - (let ([s (bytes-ref s 0)]) - (if (is-delim? s) - null - (cons (integer->char s) - (loop (sub1 counter))))) - null))))]) + (let* ([l + ;; As fast path, accum integer result + (let loop ([counter 50][c c0][v 0]) + (if (zero? counter) + null + (if (or (not c) + (is-delim? c)) + (or v null) + (let ([rest (loop (sub1 counter) + (send-generic f in-read-byte) + (and v + (c . >= . (char->integer #\0)) + (c . <= . (char->integer #\9)) + (+ (* v 10) (- c (char->integer #\0)))))]) + (if (exact-integer? rest) + rest + (cons (integer->char c) rest))))))]) (inc-item-count) - (let ([n (string->number (list->string l))]) + (let ([n (if (exact-integer? l) + l + (string->number (list->string l)))]) (cond - [(or (not n) - (not (real? n)) - (and get-exact? (not (exact-integer? n)))) - (set! is-bad? #t) - (if get-exact? 0 0.0)] - [get-exact? n] + [(and get-exact? (exact-integer? n)) n] + [(real? n) (exact->inexact n)] [else - (exact->inexact n)])))))) + (set! is-bad? #t) + (if get-exact? 0 0.0)])))))) (define/private (get-a-string limit recur?) (let* ([orig-len (if recur? (if (limit . < . 16) limit 16) - (get-exact))] + (let ([v (get-exact)]) + (if (check-boundary) + 0 + v)))] [buf (make-bytes 32)] [fail (lambda () (set! is-bad? #t) @@ -447,20 +467,22 @@ (success) (loop))))])))) + (def/public (get-fixed-exact) + (if (check-boundary) + 0 + (if (read-version . < . 8) + (let ([buf (make-bytes 4)]) + (send f read-bytes buf) + (integer-bytes->integer + buf + #t + (if (= read-version 1) + (system-big-endian?) + #t))) + (get-exact)))) + (def/public (get-fixed [box? vb]) - (let ([v (if (check-boundary) - 0 - (if (read-version . < . 8) - (let ([buf (make-bytes 4)]) - (send f read-bytes buf) - (integer-bytes->integer - buf - #t - (if (= read-version 1) - (system-big-endian?) - #t))) - (get-exact)))]) - (set-box! vb v))) + (set-box! vb (get-fixed-exact))) #| integer format specified by first byte: @@ -569,7 +591,7 @@ #t (cond [(and (pair? boundaries) - (items . > . (car boundaries))) + (items . >= . (car boundaries))) (set! is-bad? #t) (error 'editor-stream-in% "overread (caused by file corruption?; ~a vs ~a)" items (car boundaries))] @@ -647,6 +669,7 @@ (bytes-append spc (make-bytes (- 11 (string-length s)) (char->integer #\space)) (string->bytes/latin-1 s)))) + (set! col new-col) (set! items (add1 items))) this) diff --git a/collects/mred/private/wxme/text.ss b/collects/mred/private/wxme/text.ss index 9f14bf29be..eb78bee857 100644 --- a/collects/mred/private/wxme/text.ss +++ b/collects/mred/private/wxme/text.ss @@ -384,7 +384,7 @@ (not (zero? how-close)) ((abs how-close) . > . between-threshold))]) (let ([snip (and onit? - (find-snip pos 'after))]) + (do-find-snip pos 'after))]) (and snip (let-boxes ([x 0.0] [y 0.0]) (get-snip-position-and-location snip #f x y) @@ -428,7 +428,7 @@ ((abs how-close) . > . between-threshold))]) (if onit? ;; we're in the snip's horizontal region... - (let ([snip (find-snip now 'after)]) + (let ([snip (do-find-snip now 'after)]) ;; ... but maybe the mouse is above or below it. (let-boxes ([top 0.0] [bottom 0.0] @@ -1332,7 +1332,7 @@ (let* ([gsnip (if (not did-one?) (begin (make-snipset start start) - (find-snip start 'after-or-none)) + (do-find-snip start 'after-or-none)) before-snip)] [before-snip (or before-snip gsnip)] [inserted-new-line? @@ -1534,7 +1534,7 @@ [(or (equal? c #\newline) (equal? c #\tab)) (let ([newline? (equal? c #\newline)]) (make-snipset (+ i start) (+ i start 1)) - (let ([snip (find-snip (+ i start) 'after)]) + (let ([snip (do-find-snip (+ i start) 'after)]) (if newline? ;; forced return - split the snip @@ -1611,7 +1611,7 @@ (when (eq? (mline-last-snip (snip->line snip)) snip) (set-mline-last-snip! (snip->line tabsnip) tabsnip)))))) - (let ([snip (find-snip (+ i start 1) 'after)]) + (let ([snip (do-find-snip (+ i start 1) 'after)]) (let ([i (add1 i)]) (loop (+ i start) (if (= i addlen) #f (string-snip-buffer snip)) @@ -1623,7 +1623,7 @@ [(cnt . > . MAX-COUNT-FOR-SNIP) ;; divide up snip, because it's too large: (make-snipset (+ i start) (+ i start)) - (let ([snip (find-snip (+ i start) 'after)]) + (let ([snip (do-find-snip (+ i start) 'after)]) (loop (+ i start) (string-snip-buffer snip) (add1 (string-snip-dtext snip)) @@ -1711,8 +1711,8 @@ (make-snipset start end) (set! revision-count (add1 revision-count)) - (let* ([start-snip (find-snip start 'before-or-none)] - [end-snip (find-snip end 'before)] + (let* ([start-snip (do-find-snip start 'before-or-none)] + [end-snip (do-find-snip end 'before)] [with-undo? (and with-undo? (zero? s-noundomode))] [rec (if with-undo? @@ -1956,8 +1956,8 @@ s-style-list)]) (set-common-copy-region-data! (get-region-data startp endp)) - (let ([start (find-snip startp 'after)] - [end (find-snip endp 'after-or-none)] + (let ([start (do-find-snip startp 'after)] + [end (do-find-snip endp 'after-or-none)] [wl? write-locked?] [fl? flow-locked?]) @@ -2050,7 +2050,7 @@ (let ([addpos (snip->count snip)]) (insert snip read-insert) (when data - (let ([snip (find-snip read-insert 'after)]) + (let ([snip (do-find-snip read-insert 'after)]) (set-snip-data snip data))) (set! read-insert (+ read-insert addpos)))) @@ -2300,8 +2300,8 @@ ((clickback-end c) . > . start) ;; we're in the right horizontal region, but maybe the mouse ;; is above or below the clickback - (let ([start (find-snip (clickback-start c) 'after)] - [end (find-snip (clickback-end c) 'before)]) + (let ([start (do-find-snip (clickback-start c) 'after)] + [end (do-find-snip (clickback-end c) 'before)]) (and start end (let-boxes ([top 0.0] @@ -2510,18 +2510,20 @@ (send s-style-list new-named-style "Standard" (send s-style-list basic-style)) (send mf ok?))))))] [(or (eq? format 'text) (eq? format 'text-force-cr)) - (let loop ([saved-cr? #f]) - (let ([l (read-string 256 f)]) - (unless (eof-object? l) - (let ([l2 (if (equal? l "") - l - (if (equal? #\return (string-ref l (sub1 (string-length l)))) - (substring l 0 (sub1 (string-length l))) - l))]) - (insert (regexp-replace* #rx"\r\n" - (if saved-cr? (string-append "\r" l2) l2) - "\n")) - (loop (not (eq? l l2))))))) + (let ([s (make-string 1024)]) + (let loop ([saved-cr? #f]) + (let ([len (read-string! s f)]) + (unless (eof-object? len) + (let* ([s1 (if (= len (string-length s)) + s + (substring s 0 len))] + [s2 (if (equal? #\return (string-ref s1 (sub1 len))) + (substring s1 0 (sub1 len)) + s1)]) + (insert (regexp-replace* #rx"\r\n" + (if saved-cr? (string-append "\r" s2) s2) + "\n")) + (loop (not (eq? s1 s2)))))))) #f])]) (when fileerr? @@ -2558,7 +2560,6 @@ (when fileerr? (error (method-name 'text% 'save-port) "error writing editor content")) #t))) - (define/private (do-read-from-file f start overwritestyle?) (if write-locked? @@ -2579,9 +2580,9 @@ (define/override (read-from-file . args) (case-args args - [([editor-stream-in% f] [exact-nonnegative-integer? start] [any? [overwritestyle? #t]]) + [([editor-stream-in% f] [exact-nonnegative-integer? start] [any? [overwritestyle? #f]]) (do-read-from-file f start overwritestyle?)] - [([editor-stream-in% f] [any? [overwritestyle? #t]]) + [([editor-stream-in% f] [any? [overwritestyle? #f]]) (do-read-from-file f 'start overwritestyle?)] (method-name 'text% 'read-from-file))) @@ -2605,8 +2606,8 @@ len end) start)]) - (let ([start-snip (if (zero? len) #f (find-snip start 'after))] - [end-snip (if (zero? len) #f (find-snip end 'after-or-none))]) + (let ([start-snip (if (zero? len) #f (do-find-snip start 'after))] + [end-snip (if (zero? len) #f (do-find-snip end 'after-or-none))]) (and (do-write-headers-footers f #t) (write-snips-to-file f s-style-list #f start-snip end-snip #f this) (do-write-headers-footers f #f)))))) @@ -3524,7 +3525,7 @@ (cond [new-style new-style] [caret-style (send s-style-list find-or-create-style caret-style delta)] - [else (let ([gsnip (find-snip start 'before)]) + [else (let ([gsnip (do-find-snip start 'before)]) (send s-style-list find-or-create-style (snip->style gsnip) delta))])))] [else (set! write-locked? #t) @@ -3544,7 +3545,7 @@ (begin (set! initial-style-needed? #f) (values snips #f)) - (values (find-snip start 'after) (find-snip end 'after-or-none)))] + (values (do-find-snip start 'after) (do-find-snip end 'after-or-none)))] [(rec) (and (zero? s-noundomode) (make-object style-change-record% start end @@ -4007,8 +4008,6 @@ (set! write-locked? #t) (set! flow-locked? #t) - (set-box! a-ptr #f) - (set-box! b-ptr #f) (send snip split pos a-ptr b-ptr) (set! read-locked? #f) @@ -4071,7 +4070,8 @@ (splice-snip snip prev next) (set! snip-count (add1 snip-count)) (insert-snip snip ins-snip) - (extra snip) + (when extra + (extra snip)) (snip-set-admin snip snip-admin) (snip-set-admin ins-snip snip-admin) @@ -4084,11 +4084,11 @@ (let-values ([(snip s-pos) (find-snip/pos start 'after-or-none)]) (when snip (unless (= s-pos start) - (split-one start s-pos snip void))))) + (split-one start s-pos snip #f))))) (when (positive? end) (let-values ([(snip s-pos) (find-snip/pos end 'before)]) (unless (= (+ s-pos (snip->count snip)) end) - (split-one end s-pos snip void))))) + (split-one end s-pos snip #f))))) (define/private (insert-text-snip start style) (let* ([snip (on-new-string-snip)] @@ -4257,6 +4257,11 @@ #f snips)) + (define/private (do-find-snip p direction) + ;; BEWARE: `len' may not be up-to-date + (let-values ([(snip pos) (find-snip/pos p direction)]) + snip)) + (def/public (find-snip [exact-nonnegative-integer? p] [(symbol-in before-or-none before after after-or-none) direction] [maybe-box? [s-pos #f]]) @@ -4270,48 +4275,49 @@ (cond [(and (eq? direction 'before-or-none) (zero? p)) (values #f 0)] - [(and (eq? direction 'after-or-none) (p . >= . (let ([l (mline-last (unbox line-root-box))]) - (+ (mline-get-position l) - (mline-len l))))) - (values #f 0)] [else (let* ([line (mline-find-position (unbox line-root-box) p)] [pos (mline-get-position line)] [p (- p pos)]) + (if (and (eq? direction 'after-or-none) + (not (mline-next line)) + (p . >= . (mline-len line))) + ;; past the end: + (values #f 0) + ;; within the line: + (let-values ([(snip pos p) + (let ([snip (mline-snip line)]) + (if (and (zero? p) (snip->prev snip)) + ;; back up one: + (let ([snip (snip->prev snip)]) + (values snip + (- pos (snip->count snip)) + (+ p (snip->count snip)))) + (values snip pos p)))]) - (let-values ([(snip pos p) - (let ([snip (mline-snip line)]) - (if (and (zero? p) (snip->prev snip)) - ;; back up one: - (let ([snip (snip->prev snip)]) - (values snip - (- pos (snip->count snip)) - (+ p (snip->count snip)))) - (values snip pos p)))]) - - (let loop ([snip snip] - [pos pos] - [p p]) - (if snip - (let ([p (- p (snip->count snip))]) - (cond - [(or (and (eq? direction 'on) - (zero? p)) - (and (or (eq? direction 'before) - (eq? direction 'before-or-none)) - (p . <= . 0)) - (and (or (eq? direction 'after) - (eq? direction 'after-or-none)) - (p . < . 0))) - (values snip pos)] - [(and (eq? direction 'on) - (p . < . 0)) - (values #f 0)] - [else - (loop (snip->next snip) (+ pos (snip->count snip)) p)])) - (if (not (eq? direction 'after-or-none)) - (values last-snip (- pos (snip->count last-snip))) - (values #f 0))))))])) + (let loop ([snip snip] + [pos pos] + [p p]) + (if snip + (let ([p (- p (snip->count snip))]) + (cond + [(or (and (eq? direction 'on) + (zero? p)) + (and (or (eq? direction 'before) + (eq? direction 'before-or-none)) + (p . <= . 0)) + (and (or (eq? direction 'after) + (eq? direction 'after-or-none)) + (p . < . 0))) + (values snip pos)] + [(and (eq? direction 'on) + (p . < . 0)) + (values #f 0)] + [else + (loop (snip->next snip) (+ pos (snip->count snip)) p)])) + (if (not (eq? direction 'after-or-none)) + (values last-snip (- pos (snip->count last-snip))) + (values #f 0)))))))])) (def/public (find-next-non-string-snip [(make-or-false snip%) snip]) (if (or (and snip @@ -4715,9 +4721,9 @@ (cond [(not (= delayedscroll -1)) - (scroll-to-position/refresh delayedscroll delayedscrollateol? #f - delayedscrollend delayedscrollbias) - (set! refresh-all? #t)] + (when (scroll-to-position/refresh delayedscroll delayedscrollateol? #f + delayedscrollend delayedscrollbias) + (set! refresh-all? #t))] [delayedscrollbox? (set! delayedscrollbox? #f) (when (do-scroll-to delayedscrollsnip delayedscroll-x delayedscroll-y @@ -4728,7 +4734,7 @@ (send s-admin get-dc x y) (when (or (not (= origx x)) (not (= origy y))) (set! refresh-all? #t))) - + (let-boxes ([x 0.0] [y 0.0] [w 0.0] [h 0.0]) (send s-admin get-max-view x y w h) (let ([top y] diff --git a/collects/mred/private/wxme/undo.ss b/collects/mred/private/wxme/undo.ss index 15f44fbdc3..053b3f82fe 100644 --- a/collects/mred/private/wxme/undo.ss +++ b/collects/mred/private/wxme/undo.ss @@ -4,7 +4,8 @@ "snip.ss" "snip-flags.ss") -(provide proc-record% +(provide change-record% + proc-record% unmodify-record% insert-record% insert-snip-record% diff --git a/collects/r6rs/scribblings/r6rs.scrbl b/collects/r6rs/scribblings/r6rs.scrbl index d7977b8ff6..7a1206a377 100644 --- a/collects/r6rs/scribblings/r6rs.scrbl +++ b/collects/r6rs/scribblings/r6rs.scrbl @@ -360,6 +360,11 @@ several known ways: instead of @|r6rs| bindings. In particular, @scheme[=>], @scheme[else], @scheme[_], and @scheme[...] are not bound.} + @item{Bindings for @schemeidfont{#%datum}, @schemeidfont{#%app}, + @schemeidfont{#%top}, and @schemeidfont{#%top-interaction} are + imported into every library and program, and at every phase + level for which the library or program has imports.} + ] diff --git a/collects/redex/private/reduction-semantics.ss b/collects/redex/private/reduction-semantics.ss index 49610d1d13..7fdb50eb2c 100644 --- a/collects/redex/private/reduction-semantics.ss +++ b/collects/redex/private/reduction-semantics.ss @@ -1843,6 +1843,8 @@ (values (apply-reduction-relation red arg) #f)) (define (test-->>/procs red arg expected apply-red cycles-ok? srcinfo) + (unless (reduction-relation? red) + (error 'test--> "expected a reduction relation as first argument, got ~e" red)) (let-values ([(got got-cycle?) (apply-red red arg)]) (inc-tests) diff --git a/collects/redex/private/rg-test.ss b/collects/redex/private/rg-test.ss index 04749ba050..6658379577 100644 --- a/collects/redex/private/rg-test.ss +++ b/collects/redex/private/rg-test.ss @@ -347,6 +347,10 @@ (test (generate-term lang (side-condition a (odd? (term a))) 5) 43) (test (raised-exn-msg exn:fail:redex? (generate-term lang c 5)) #rx"unable to generate") + (test (let/ec k + (generate-term lang (number_1 (side-condition any (k (term number_1)))) 5)) + 'number_1) + (test ; mismatch patterns work with side-condition failure/retry (generate-term/decisions lang e 5 0 @@ -840,6 +844,89 @@ (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/rg.ss b/collects/redex/private/rg.ss index e459984444..be8da98838 100644 --- a/collects/redex/private/rg.ss +++ b/collects/redex/private/rg.ss @@ -178,12 +178,12 @@ [parsed (parse-language lang)]) (make-rg-lang parsed lits (unique-chars lits) (find-base-cases parsed)))) -(define (generate lang decisions@ retries what) +(define (generate lang decisions@ user-gen retries what) (define-values/invoke-unit decisions@ (import) (export decisions^)) (define ((generate-nt lang base-cases generate pref-prods) - name cross? size attempt in-hole state) + name cross? size attempt in-hole env) (let*-values ([(term _) (generate/pred @@ -195,14 +195,12 @@ ((if cross? base-cases-cross base-cases-non-cross) base-cases)) ((next-non-terminal-decision) name cross? lang attempt pref-prods)))]) - (generate (max 0 (sub1 size)) attempt - (make-state #hash()) - in-hole (rhs-pattern rhs)))) + (generate (max 0 (sub1 size)) attempt empty-env in-hole (rhs-pattern rhs)))) (λ (_ env) (mismatches-satisfied? env)) size attempt)]) term)) - (define (generate-sequence ellipsis generate state length) + (define (generate-sequence ellipsis generate env length) (define (split-environment env) (foldl (λ (var seq-envs) (let ([vals (hash-ref env var #f)]) @@ -213,17 +211,17 @@ (define (merge-environments seq-envs) (foldl (λ (var env) (hash-set env var (map (λ (seq-env) (hash-ref seq-env var)) seq-envs))) - (state-env state) (ellipsis-vars ellipsis))) + env (ellipsis-vars ellipsis))) (let-values ([(seq envs) - (let recur ([envs (split-environment (state-env state))]) + (let recur ([envs (split-environment env)]) (if (null? envs) (values null null) (let*-values - ([(term state) (generate (make-state (car envs)) the-hole (ellipsis-pattern ellipsis))] + ([(term env) (generate (car envs) the-hole (ellipsis-pattern ellipsis))] [(terms envs) (recur (cdr envs))]) - (values (cons term terms) (cons (state-env state) envs)))))]) - (values seq (make-state (merge-environments envs))))) + (values (cons term terms) (cons env envs)))))]) + (values seq (merge-environments envs)))) (define (generate/pred name gen pred init-sz init-att) (let ([pre-threshold-incr @@ -244,9 +242,9 @@ name retries (if (= retries 1) "" "s")) - (let-values ([(term state) (gen size attempt)]) - (if (pred term (state-env state)) - (values term state) + (let-values ([(term env) (gen size attempt)]) + (if (pred term env) + (values term env) (retry (sub1 remaining) (if (incr-size? remaining) (add1 size) size) (+ attempt @@ -254,13 +252,13 @@ post-threshold-incr pre-threshold-incr))))))))) - (define (generate/prior name state generate) + (define (generate/prior name env generate) (let* ([none (gensym)] - [prior (hash-ref (state-env state) name none)]) + [prior (hash-ref env name none)]) (if (eq? prior none) - (let-values ([(term state) (generate)]) - (values term (set-env state name term))) - (values prior state)))) + (let-values ([(term env) (generate)]) + (values term (hash-set env name term))) + (values prior env)))) (define (mismatches-satisfied? env) (let ([groups (make-hasheq)]) @@ -276,10 +274,7 @@ (and (not (hash-ref prior val #f)) (hash-set! prior val #t))))))) - (define-struct state (env)) - (define new-state (make-state #hash())) - (define (set-env state name value) - (make-state (hash-set (state-env state) name value))) + (define empty-env #hash()) (define (bindings env) (make-bindings @@ -288,111 +283,139 @@ (cons (make-bind (binder-name key) val) bindings) bindings)))) - (define (generate-pat lang sexp pref-prods size attempt state in-hole pat) - (define recur (curry generate-pat lang sexp pref-prods size attempt)) - (define recur/pat (recur state in-hole)) + (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 recur/pat (recur env in-hole)) (define ((recur/pat/size-attempt pat) size attempt) - (generate-pat lang sexp pref-prods size attempt state in-hole pat)) + (generate-pat lang sexp pref-prods user-gen user-acc 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) + (curry generate-pat lang sexp pref-prods user-gen user-acc) pref-prods)) - (match pat - [`number (values ((next-number-decision) attempt) state)] - [`natural (values ((next-natural-decision) attempt) state)] - [`integer (values ((next-integer-decision) attempt) state)] - [`real (values ((next-real-decision) attempt) state)] - [`(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-chars lang) (rg-lang-lits lang) attempt) - state)] - [`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 state) (recur/pat 'variable)]) - (values (symbol-append prefix term) state))] - [`string - (values ((next-string-decision) (rg-lang-chars lang) (rg-lang-lits lang) attempt) - state)] - [`(side-condition ,pat ,(? procedure? condition)) - (generate/pred (unparse-pattern pat) - (recur/pat/size-attempt pat) - (λ (_ env) (condition (bindings env))) - size attempt)] - [`(name ,(? symbol? id) ,p) - (let-values ([(term state) (recur/pat p)]) - (values term (set-env state (make-binder id) term)))] - [`hole (values in-hole state)] - [`(in-hole ,context ,contractum) - (let-values ([(term state) (recur/pat contractum)]) - (recur state term context))] - [`(hide-hole ,pattern) (recur state 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 size attempt new-state the-hole nt)]) - (values term state))] - [(? (is-nt? clang)) - (values (gen-nt pat #f size attempt in-hole state) state)] - [(struct binder ((and name (or (? (is-nt? clang) nt) (app (symbol-match named-nt-rx) (? (is-nt? clang) nt)))))) - (generate/prior pat state (λ () (values (gen-nt nt #f size attempt in-hole state) state)))] - [(struct binder ((or (? built-in? b) (app (symbol-match named-nt-rx) (? built-in? b))))) - (generate/prior pat state (λ () (recur/pat b)))] - [(struct mismatch (name (app (symbol-match mismatch-nt-rx) (? symbol? (? (is-nt? clang) nt))))) - (let ([term (gen-nt nt #f size attempt in-hole state)]) - (values term (set-env state pat term)))] - [(struct mismatch (name (app (symbol-match mismatch-nt-rx) (? symbol? (? built-in? b))))) - (let-values ([(term state) (recur/pat b)]) - (values term (set-env state pat term)))] - [`(cross ,(? symbol? cross-nt)) - (values (gen-nt cross-nt #t size attempt in-hole state) state)] - [(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) (values pat state)] - [(list-rest (and (struct ellipsis (name sub-pat class vars)) ellipsis) rest) - (let*-values ([(length) (let ([prior (hash-ref (state-env state) class #f)]) - (if prior prior ((next-sequence-decision) attempt)))] - [(seq state) (generate-sequence ellipsis recur state length)] - [(rest state) (recur (set-env (set-env state class length) name length) + (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-chars lang) (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-chars lang) (rg-lang-lits lang) attempt) + env)] + [`(side-condition ,pat ,(? procedure? condition)) + (generate/pred (unparse-pattern pat) + (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) state))] - [(list-rest pat rest) - (let*-values - ([(pat-term state) (recur/pat pat)] - [(rest-term state) (recur state in-hole rest)]) - (values (cons pat-term rest-term) state))] - [else - (error what "unknown pattern ~s\n" pat)])) + (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)) (let ([rg-lang (prepare-lang lang)] [rg-sexp (prepare-lang sexp)]) (λ (pat) (let ([parsed (reassign-classes (parse-pattern pat lang 'top-level))]) (λ (size attempt) - (let-values ([(term state) + (let-values ([(term env) (generate/pred pat (λ (size attempt) (generate-pat - rg-lang rg-sexp ((next-pref-prods-decision) (rg-lang-clang rg-lang)) - size attempt new-state the-hole parsed)) + rg-lang + rg-sexp + ((next-pref-prods-decision) (rg-lang-clang rg-lang)) + user-gen + #f + size + attempt + empty-env + the-hole + parsed)) (λ (_ env) (mismatches-satisfied? env)) size attempt)]) - (values term (bindings (state-env state))))))))) + (values term (bindings env)))))))) (define-struct base-cases (cross non-cross)) @@ -658,22 +681,31 @@ (unless (reduction-relation? x) (raise-type-error 'redex-check "reduction-relation" x))) -(define-for-syntax (term-generator lang pat decisions@ retries what) +(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) (with-syntax ([pattern (rewrite-side-conditions/check-errs (language-id-nts lang what) what #t pat)]) - #`((generate #,lang #,decisions@ #,retries '#,what) `pattern))) + #`((generate #,lang #,decisions@ #,custom #,retries '#,what) `pattern))) (define-syntax (generate-term stx) (syntax-case stx () [(_ lang pat size . kw-args) - (with-syntax ([(attempt retries) + (with-syntax ([(attempt retries custom) (parse-kw-args `((#:attempt . 1) - (#:retries . ,#'default-retries)) + (#:retries . ,#'default-retries) + (#:custom . ,#'defer-all)) (syntax kw-args) stx)]) - (with-syntax ([generate (term-generator #'lang #'pat #'(generation-decisions) #'retries 'generate-term)]) + (with-syntax ([generate (term-generator #'lang + #'pat + #'(generation-decisions) + #'custom + #'retries + 'generate-term)]) (syntax/loc stx (let-values ([(term _) (generate size attempt)]) term))))] @@ -702,25 +734,35 @@ (let-values ([(names names/ellipses) (extract-names (language-id-nts #'lang 'redex-check) 'redex-check #t #'pat)] - [(attempts-stx source-stx retries-stx) + [(attempts-stx source-stx retries-stx custom-stx) (apply values (parse-kw-args `((#:attempts . ,#'default-check-attempts) (#:source . #f) - (#:retries . ,#'default-retries)) + (#:retries . ,#'default-retries) + (#:custom . ,#'defer-all)) (syntax kw-args) stx))]) (with-syntax ([(name ...) names] [(name/ellipses ...) names/ellipses] - [attempts attempts-stx] - [retries retries-stx] [show (show-message stx)]) (with-syntax ([property (syntax (λ (_ bindings) (term-let ([name/ellipses (lookup-binding bindings 'name)] ...) property)))]) (quasisyntax/loc stx - (let ([att attempts] - [ret retries]) + (let ([att #,attempts-stx] + [ret #,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 '+ '-)]) (assert-nat 'redex-check att) (assert-nat 'redex-check ret) (unsyntax @@ -739,14 +781,21 @@ (map rewrite-proc-lhs (reduction-relation-make-procs r)) (reduction-relation-srcs r) (reduction-relation-lang r)))])]) - (check-prop-srcs - lang pats srcs property random-decisions@ (max 1 (floor (/ att (length pats)))) ret + (check-prop-srcs + lang + pats + srcs + property + random-decisions@ + custom + (max 1 (floor (/ att (length pats)))) + ret 'redex-check 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@ #'ret 'redex-check) + #,(term-generator #'lang #'pat #'random-decisions@ #'custom #'ret 'redex-check) property att show))) (void))))))])) @@ -793,9 +842,10 @@ [(_ name . kw-args) (identifier? #'name) (with-syntax ([m (metafunc/err #'name stx)] - [(attempts retries) + [(attempts retries custom) (parse-kw-args `((#:attempts . ,#'default-check-attempts) - (#:retries . ,#'default-retries)) + (#:retries . ,#'default-retries) + (#:custom . ,#'defer-all)) (syntax kw-args) stx)] [show (show-message stx)]) @@ -806,7 +856,7 @@ [att attempts]) (assert-nat 'check-metafunction-contract att) (check-prop - ((generate lang decisions@ retries 'check-metafunction-contract) + ((generate lang decisions@ custom retries 'check-metafunction-contract) (if dom dom '(any (... ...)))) (λ (t _) (with-handlers ([exn:fail:redex? (λ (_) #f)]) @@ -814,10 +864,10 @@ att show))))])) -(define (check-prop-srcs lang pats srcs prop decisions@ attempts retries what show +(define (check-prop-srcs lang pats srcs prop decisions@ custom attempts retries what show [match #f] [match-fail #f]) - (let ([lang-gen (generate lang decisions@ retries what)]) + (let ([lang-gen (generate lang decisions@ custom retries what)]) (when (for/and ([pat pats] [src srcs]) (check (lang-gen pat) @@ -839,9 +889,10 @@ (syntax-case stx () [(_ name property . kw-args) (with-syntax ([m (metafunc/err #'name stx)] - [(attempts retries) + [(attempts retries custom) (parse-kw-args `((#:attempts . , #'default-check-attempts) - (#:retries . ,#'default-retries)) + (#:retries . ,#'default-retries) + (#:custm . ,#'defer-all)) (syntax kw-args) stx)] [show (show-message stx)]) @@ -855,6 +906,7 @@ (metafunc-srcs m) (λ (term _) (property term)) (generation-decisions) + custom att ret 'check-metafunction @@ -867,10 +919,11 @@ (define-syntax (check-reduction-relation stx) (syntax-case stx () [(_ relation property . kw-args) - (with-syntax ([(attempts retries decisions@) + (with-syntax ([(attempts retries decisions@ custom) (parse-kw-args `((#:attempts . , #'default-check-attempts) (#:retries . ,#'default-retries) - (#:decisions . ,#'random-decisions@)) + (#:decisions . ,#'random-decisions@) + (#:custom . ,#'defer-all)) (syntax kw-args) stx)] [show (show-message stx)]) @@ -886,6 +939,7 @@ (reduction-relation-srcs rel) (λ (term _) (property term)) decisions@ + custom attempts retries 'check-reduction-relation diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl index feebc5593b..122d6f7e88 100644 --- a/collects/redex/redex.scrbl +++ b/collects/redex/redex.scrbl @@ -857,7 +857,7 @@ terminate (it does terminate if the only infinite reduction paths are cyclic). error elsewhere. } @defidform[fresh]{ Recognized specially within - @scheme[reduction-relation]. A @scheme[-->] form is an + @scheme[reduction-relation]. A @scheme[fresh] form is an error elsewhere. } @defidform[with]{ Recognized specially within diff --git a/collects/scheme/dict.ss b/collects/scheme/dict.ss index 6648afbe29..e90cf849bb 100644 --- a/collects/scheme/dict.ss +++ b/collects/scheme/dict.ss @@ -150,7 +150,7 @@ [(dict-struct? d) ((get-dict-ref (dict-struct-ref d)) d key)] [else - (raise-type-error 'dict-ref 'dict 0 d key)])] + (raise-type-error 'dict-ref "dict" 0 d key)])] [(d key default) (cond [(hash? d) (hash-ref d key default)] @@ -170,7 +170,7 @@ [(dict-struct? d) ((get-dict-ref (dict-struct-ref d)) d key default)] [else - (raise-type-error 'dict-ref 'dict 0 d key default)])])) + (raise-type-error 'dict-ref "dict" 0 d key default)])])) (define (dict-set! d key val) (cond diff --git a/collects/scheme/package.ss b/collects/scheme/package.ss index cf091fc55b..469ce825f5 100644 --- a/collects/scheme/package.ss +++ b/collects/scheme/package.ss @@ -2,7 +2,8 @@ (require (for-syntax scheme/base syntax/kerncase syntax/boundmap - syntax/define)) + syntax/define + syntax/flatten-begin)) (provide define-package package-begin @@ -93,6 +94,12 @@ hidden) id))) +(define-for-syntax (move-props orig new) + (datum->syntax new + (syntax-e new) + orig + orig)) + (define-for-syntax (do-define-package stx exp-stx) (syntax-case exp-stx () [(_ pack-id mode exports form ...) @@ -293,7 +300,7 @@ (car def-ctxes)))]) (syntax-case expr (begin) [(begin . rest) - (loop (append (syntax->list #'rest) (cdr exprs)) + (loop (append (flatten-begin expr) (cdr exprs)) rev-forms def-ctxes)] [(def (id ...) rhs) @@ -315,7 +322,7 @@ (syntax-local-bind-syntaxes ids #'rhs def-ctx) (register-bindings! ids) (loop (cdr exprs) - (cons #`(define-syntaxes #,ids rhs) + (cons (move-props expr #`(define-syntaxes #,ids rhs)) rev-forms) (if star? (cons def-ctx def-ctxes) def-ctxes)))))] [(def (id ...) rhs) @@ -325,7 +332,7 @@ (let ([star? (free-identifier=? #'def #'-define*-values)] [ids (syntax->list #'(id ...))]) (let* ([def-ctx (if star? - (syntax-local-make-definition-context) + (syntax-local-make-definition-context (car def-ctxes)) (car def-ctxes))] [ids (if star? (map (add-package-context (list def-ctx)) ids) @@ -333,7 +340,7 @@ (syntax-local-bind-syntaxes ids #f def-ctx) (register-bindings! ids) (loop (cdr exprs) - (cons #`(define-values #,ids rhs) rev-forms) + (cons (move-props expr #`(define-values #,ids rhs)) rev-forms) (if star? (cons def-ctx def-ctxes) def-ctxes))))] [else (loop (cdr exprs) diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index a9040846b5..a0831ca2d3 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -11,6 +11,7 @@ syntax/name syntax/context syntax/define + syntax/flatten-begin syntax/private/boundmap mzlib/stxparam "classidmap.ss")) @@ -245,9 +246,9 @@ null (let ([e (expand (car l))]) (syntax-case e (begin define-syntaxes define-values) - [(begin expr ...) + [(begin . _) (loop (append - (syntax->list (syntax (expr ...))) + (flatten-begin e) (cdr l)))] [(define-syntaxes (id ...) rhs) (andmap identifier? (syntax->list #'(id ...))) @@ -1131,6 +1132,8 @@ (if (null? l) null (cons pos (loop (add1 pos) (cdr l)))))] + [(local-field-accessor ...) (generate-temporaries (append field-names private-field-names))] + [(local-field-mutator ...) (generate-temporaries (append field-names private-field-names))] [(plain-init-name ...) (definify plain-init-names)] [(plain-init-name-localized ...) (map lookup-localize plain-init-names)] [(local-plain-init-name ...) (generate-temporaries plain-init-names)]) @@ -1164,9 +1167,9 @@ (quote the-obj) (quote-syntax local-field) (quote-syntax local-field-localized) - (quote-syntax local-accessor) - (quote-syntax local-mutator) - '(local-field-pos)) + (quote-syntax local-field-accessor) + (quote-syntax local-field-mutator) + '()) ... (make-rename-super-map (quote-syntax the-finder) (quote the-obj) @@ -1324,126 +1327,130 @@ rename-super-temp ... rename-super-extra-temp ... rename-inner-temp ... rename-inner-extra-temp ... method-accessor ...) ; for a local call that needs a dynamic lookup - (syntax-parameterize - ([this-param (make-this-map (quote-syntax this-id) - (quote-syntax the-finder) - (quote the-obj))]) - (let-syntaxes - mappings - (syntax-parameterize - ([super-param - (lambda (stx) - (syntax-case stx (rename-super-extra-orig ...) - [(_ rename-super-extra-orig . args) - (generate-super-call - stx - (quote-syntax the-finder) - (quote the-obj) - (quote-syntax rename-super-extra-temp) - (syntax args))] - ... - [(_ id . args) - (identifier? #'id) - (raise-syntax-error - #f - (string-append - "identifier for super call does not have an override, " - "override-final, overment, or inherit/super declaration") - stx - #'id)] - [_else - (raise-syntax-error - #f - "expected an identifier after the keyword" - stx)]))] - [inner-param - (lambda (stx) - (syntax-case stx (rename-inner-extra-orig ...) - [(_ default-expr rename-inner-extra-orig . args) - (generate-inner-call - stx - (quote-syntax the-finder) - (quote the-obj) - (syntax default-expr) - (quote-syntax rename-inner-extra-temp) - (syntax args))] - ... - [(_ default-expr id . args) - (identifier? #'id) - (raise-syntax-error - #f - (string-append - "identifier for inner call does not have a pubment, augment, " - "overment, or inherit/inner declaration") - stx - #'id)] - [(_) - (raise-syntax-error - #f - "expected a default-value expression after the keyword" - stx - #'id)] - [_else - (raise-syntax-error - #f - "expected an identifier after the keyword and default-value expression" - stx)]))]) - stx-def ... - (letrec ([private-temp private-method] - ... - [pubment-temp pubment-method] - ... - [public-final-temp public-final-method] - ...) - (values - (list pubment-temp ... public-final-temp ... . public-methods) - (list . override-methods) - (list . augride-methods) - ;; Initialization - #, ;; Attach srcloc (useful for profiling) - (quasisyntax/loc stx - (lambda (the-obj super-go si_c si_inited? si_leftovers init-args) - (let-syntax ([the-finder (quote-syntax the-obj)]) - (syntax-parameterize - ([super-instantiate-param - (lambda (stx) - (syntax-case stx () - [(_ (arg (... ...)) (kw kwarg) (... ...)) - (with-syntax ([stx stx]) - (syntax (-instantiate super-go stx (the-obj si_c si_inited? - si_leftovers) - (list arg (... ...)) - (kw kwarg) (... ...))))]))] - [super-new-param - (lambda (stx) - (syntax-case stx () - [(_ (kw kwarg) (... ...)) - (with-syntax ([stx stx]) - (syntax (-instantiate super-go stx (the-obj si_c si_inited? - si_leftovers) - null - (kw kwarg) (... ...))))]))] - [super-make-object-param - (lambda (stx) - (let ([code - (quote-syntax - (lambda args - (super-go the-obj si_c si_inited? si_leftovers args null)))]) - (if (identifier? stx) - code - (datum->syntax - code - (cons code - (cdr (syntax-e stx)))))))]) - (letrec-syntaxes+values - ([(plain-init-name) (make-init-redirect - (quote-syntax set!) - (quote-syntax #%plain-app) - (quote-syntax local-plain-init-name) - (quote-syntax plain-init-name-localized))] ...) - ([(local-plain-init-name) undefined] ...) - (void) ; in case the body is empty - . exprs)))))))))))) + (let ([local-field-accessor (make-struct-field-accessor local-accessor local-field-pos #f)] + ... + [local-field-mutator (make-struct-field-mutator local-mutator local-field-pos #f)] + ...) + (syntax-parameterize + ([this-param (make-this-map (quote-syntax this-id) + (quote-syntax the-finder) + (quote the-obj))]) + (let-syntaxes + mappings + (syntax-parameterize + ([super-param + (lambda (stx) + (syntax-case stx (rename-super-extra-orig ...) + [(_ rename-super-extra-orig . args) + (generate-super-call + stx + (quote-syntax the-finder) + (quote the-obj) + (quote-syntax rename-super-extra-temp) + (syntax args))] + ... + [(_ id . args) + (identifier? #'id) + (raise-syntax-error + #f + (string-append + "identifier for super call does not have an override, " + "override-final, overment, or inherit/super declaration") + stx + #'id)] + [_else + (raise-syntax-error + #f + "expected an identifier after the keyword" + stx)]))] + [inner-param + (lambda (stx) + (syntax-case stx (rename-inner-extra-orig ...) + [(_ default-expr rename-inner-extra-orig . args) + (generate-inner-call + stx + (quote-syntax the-finder) + (quote the-obj) + (syntax default-expr) + (quote-syntax rename-inner-extra-temp) + (syntax args))] + ... + [(_ default-expr id . args) + (identifier? #'id) + (raise-syntax-error + #f + (string-append + "identifier for inner call does not have a pubment, augment, " + "overment, or inherit/inner declaration") + stx + #'id)] + [(_) + (raise-syntax-error + #f + "expected a default-value expression after the keyword" + stx + #'id)] + [_else + (raise-syntax-error + #f + "expected an identifier after the keyword and default-value expression" + stx)]))]) + stx-def ... + (letrec ([private-temp private-method] + ... + [pubment-temp pubment-method] + ... + [public-final-temp public-final-method] + ...) + (values + (list pubment-temp ... public-final-temp ... . public-methods) + (list . override-methods) + (list . augride-methods) + ;; Initialization + #, ;; Attach srcloc (useful for profiling) + (quasisyntax/loc stx + (lambda (the-obj super-go si_c si_inited? si_leftovers init-args) + (let-syntax ([the-finder (quote-syntax the-obj)]) + (syntax-parameterize + ([super-instantiate-param + (lambda (stx) + (syntax-case stx () + [(_ (arg (... ...)) (kw kwarg) (... ...)) + (with-syntax ([stx stx]) + (syntax (-instantiate super-go stx (the-obj si_c si_inited? + si_leftovers) + (list arg (... ...)) + (kw kwarg) (... ...))))]))] + [super-new-param + (lambda (stx) + (syntax-case stx () + [(_ (kw kwarg) (... ...)) + (with-syntax ([stx stx]) + (syntax (-instantiate super-go stx (the-obj si_c si_inited? + si_leftovers) + null + (kw kwarg) (... ...))))]))] + [super-make-object-param + (lambda (stx) + (let ([code + (quote-syntax + (lambda args + (super-go the-obj si_c si_inited? si_leftovers args null)))]) + (if (identifier? stx) + code + (datum->syntax + code + (cons code + (cdr (syntax-e stx)))))))]) + (letrec-syntaxes+values + ([(plain-init-name) (make-init-redirect + (quote-syntax set!) + (quote-syntax #%plain-app) + (quote-syntax local-plain-init-name) + (quote-syntax plain-init-name-localized))] ...) + ([(local-plain-init-name) undefined] ...) + (void) ; in case the body is empty + . exprs))))))))))))) ;; Not primitive: #f)))))))))))))))) @@ -2095,9 +2102,9 @@ ;; Use public field names to name the accessors and mutators (let-values ([(inh-accessors inh-mutators) (values - (map (lambda (id) (make-class-field-accessor super id)) + (map (lambda (id) (make-class-field-accessor super id #f)) inherit-field-names) - (map (lambda (id) (make-class-field-mutator super id)) + (map (lambda (id) (make-class-field-mutator super id #f)) inherit-field-names))]) ;; -- Reset field table to register accessor and mutator info -- ;; There are more accessors and mutators than public fields... @@ -2771,8 +2778,10 @@ ;; All unconsumed named-args must have #f ;; "name"s, otherwise an error is raised in ;; the leftovers checking. - (append (map (lambda (x) (cons #f x)) al) - named-args)] + (if (null? al) + named-args + (append (map (lambda (x) (cons #f x)) al) + named-args))] [else (obj-error 'instantiate "too many initialization arguments:~a~a" @@ -2950,7 +2959,7 @@ (loop (wrapper-object-wrapped loop-object))))))) - (define (class-field-X who which cwhich class name) + (define (class-field-X who which cwhich class name proc-field-name) (unless (class? class) (raise-type-error who "class" class)) (unless (symbol? name) @@ -2960,17 +2969,17 @@ (obj-error who "no such field: ~a~a" name (for-class (class-name class)))))]) - (which (cwhich (car p)) (cdr p) name))) + (which (cwhich (car p)) (cdr p) proc-field-name))) - (define (make-class-field-accessor class name) + (define (make-class-field-accessor class name keep-name?) (class-field-X 'class-field-accessor make-struct-field-accessor class-field-ref - class name)) + class name (and keep-name? name))) - (define (make-class-field-mutator class name) + (define (make-class-field-mutator class name keep-name?) (class-field-X 'class-field-mutator make-struct-field-mutator class-field-set! - class name)) + class name (and keep-name? name))) (define-struct generic (name applicable)) @@ -3051,7 +3060,7 @@ (define-syntaxes (class-field-accessor class-field-mutator generic/form) (let ([mk - (lambda (make targets) + (lambda (make targets extra-args) (lambda (stx) (syntax-case stx () [(_ class-expr name) @@ -3063,8 +3072,9 @@ stx name)) (with-syntax ([name (localize name)] - [make make]) - (syntax/loc stx (make class-expr `name))))] + [make make] + [extra-args extra-args]) + (syntax/loc stx (make class-expr `name . extra-args))))] [(_ class-expr) (raise-syntax-error #f @@ -3072,9 +3082,9 @@ targets) stx)])))]) (values - (mk (quote-syntax make-class-field-accessor) "class") - (mk (quote-syntax make-class-field-mutator) "class") - (mk (quote-syntax make-generic/proc) "class or interface")))) + (mk (quote-syntax make-class-field-accessor) "class" (list #'#t)) + (mk (quote-syntax make-class-field-mutator) "class" (list #'#t)) + (mk (quote-syntax make-generic/proc) "class or interface" null)))) (define-syntax (class-field-accessor-traced stx) (syntax-case stx () diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 52688c3f6e..5920e8a6e0 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -87,7 +87,7 @@ improve method arity mismatch contract violation error messages? define-stx)] [(_ name contract-expr) (raise-syntax-error 'define/contract - "no body after contract" + "expected a contract expression and a definition body, but found only one expression" define-stx)] [(_ name+arg-list contract #:freevars args . body) (identifier? #'args) diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss index 8888b06062..6be22c6091 100644 --- a/collects/scribble/html-render.ss +++ b/collects/scribble/html-render.ss @@ -1119,7 +1119,7 @@ (define/override (render-blockquote t part ri) `((blockquote ,(if (string? (blockquote-style t)) - `([class ,(blockquote-style t)]) + `([class ,(regexp-replace #rx"^[\\]" (blockquote-style t) "")]) `()) ,@(append-map (lambda (i) (render-block i part ri #f)) (blockquote-paragraphs t))))) diff --git a/collects/scribble/latex-render.ss b/collects/scribble/latex-render.ss index 8f0a8c7428..35dc6155b8 100644 --- a/collects/scribble/latex-render.ss +++ b/collects/scribble/latex-render.ss @@ -403,10 +403,14 @@ (define/override (render-blockquote t part ri) (let ([kind (or (blockquote-style t) "quote")]) - (printf "\\begin{~a}" kind) + (if (regexp-match #rx"^[\\]" kind) + (printf "~a{" kind) + (printf "\\begin{~a}" kind)) (parameterize ([current-table-mode (list "blockquote" t)]) (render-flow (make-flow (blockquote-paragraphs t)) part ri #f)) - (printf "\\end{~a}" kind) + (if (regexp-match #rx"^[\\]" kind) + (printf "}") + (printf "\\end{~a}" kind)) null)) (define/override (render-other i part ri) diff --git a/collects/scribble/private/manual-style.ss b/collects/scribble/private/manual-style.ss index d4f0eba918..9f49153f4c 100644 --- a/collects/scribble/private/manual-style.ss +++ b/collects/scribble/private/manual-style.ss @@ -199,10 +199,15 @@ `(part ,(doc-prefix '(lib "scribblings/guide/guide.scrbl") "hash-lang")))) (define (margin-note . c) - (make-styled-paragraph - (list (make-element "refcolumn" - (list (make-element "refcontent" (decode-content c))))) - "refpara")) + (make-blockquote + "\\refpara" + (list + (make-blockquote + "refcolumn" + (list + (make-blockquote + "refcontent" + (flow-paragraphs (decode-flow c)))))))) (define void-const (schemeresultfont "#")) diff --git a/collects/scribble/scribble.css b/collects/scribble/scribble.css index 832ef53ba5..4c7f2b626f 100644 --- a/collects/scribble/scribble.css +++ b/collects/scribble/scribble.css @@ -152,9 +152,16 @@ table td { width: 13em; font-size: 85%; border: 0.5em solid #F5F5DC; + margin: 0 0 0 0; } .refcontent { + margin: 0 0 0 0; +} + +.refcontent p { + margin-top: 0; + margin-bottom: 0; } /* ---------------------------------------- */ diff --git a/collects/scribble/scribble.tex b/collects/scribble/scribble.tex index 9362008f1d..e346c5faed 100644 --- a/collects/scribble/scribble.tex +++ b/collects/scribble/scribble.tex @@ -42,8 +42,6 @@ \newcommand{\schemeopt}[1]{#1} \newcommand{\textsub}[1]{$_{\hbox{\textsmaller{#1}}}$} \newcommand{\textsuper}[1]{$^{\hbox{\textsmaller{#1}}}$} -\newcommand{\refcolumn}[1]{#1} -\newcommand{\refcontent}[1]{#1} \newcommand{\intextcolor}[2]{\textcolor{#1}{#2}} \newcommand{\intextrgbcolor}[2]{\textcolor[rgb]{#1}{#2}} \newcommand{\incolorbox}[2]{{\fboxrule=0pt\fboxsep=0pt\colorbox{#1}{#2}}} @@ -58,9 +56,12 @@ \newcommand{\noborder}[1]{#1} \newcommand{\imageleft}[1]{} % drop it \renewcommand{\smaller}[1]{\textsmaller{#1}} -\newcommand{\refpara}[1]{\marginpar{\raggedright \footnotesize #1}} \newcommand{\planetName}[1]{PLane\hspace{-0.1ex}T} +\newcommand{\refpara}[1]{\marginpar{\raggedright \footnotesize #1}} +\newenvironment{refcolumn}{}{} +\newenvironment{refcontent}{}{} + \newcommand{\titleAndEmptyVersion}[2]{\title{#1}\maketitle} \newcommand{\titleAndVersion}[2]{\title{#1\\{\normalsize Version #2}}\maketitle} diff --git a/collects/scribblings/framework/color.scrbl b/collects/scribblings/framework/color.scrbl index 59b53cdafa..50fb40889c 100644 --- a/collects/scribblings/framework/color.scrbl +++ b/collects/scribblings/framework/color.scrbl @@ -8,25 +8,31 @@ This interface describes how coloring is stopped and started for text that knows how to color itself. It also describes how to query the lexical and s-expression structure of the text. - @defmethod*[(((start-colorer (token-sym-style (-> symbol? string?)) (get-token (-> input-port? (values any? symbol? (union false? symbol?) natural-number? natural-number?))) (pairs (listof (list/p symbol? symbol?)))) void))]{ + @defmethod*[(((start-colorer (token-sym->style (-> symbol? string?)) + (get-token (-> input-port? (values any/c + symbol? + (or/c false? symbol?) + exact-nonnegative-integer? + exact-nonnegative-integer?))) + (pairs (listof (list/p symbol? symbol?)))) void))]{ Starts tokenizing the buffer for coloring and parenthesis matching. - token-sym-style will be passed the first return symbol from get-token + The @scheme[token-sym->style] argument will be passed the first return symbol from @scheme[get-token] and should return the style-name that the token should be colored. - get-token takes an input port and returns the next token as 5 values: + The @scheme[get-token] argument takes an input port and returns the next token as 5 values: @itemize[ @item{ An unused value. This value is intended to represent the textual component of the token and may be used as such in the future.} @item{ A symbol describing the type of the token. This symbol is transformed - into a style-name via the token-sym->style argument. The symbols - 'white-space and 'comment have special meaning and should always be + into a style-name via the @scheme[token-sym->style] argument. The symbols + @scheme['white-space] and @scheme['comment] have special meaning and should always be returned for white space and comment tokens respectively. The symbol @scheme['no-color] can be used to indicate that although the token is not white - space, it should not be colored. The symbol 'eof must be used to + space, it should not be colored. The symbol @scheme['eof] must be used to indicate when all the tokens have been consumed.} @item{ A symbol indicating how the token should be treated by the paren @@ -36,7 +42,7 @@ @item{ The ending position of the token.}] - get-token will usually be implemented with a lexer using the + The @scheme[get-token] function will usually be implemented with a lexer using the @scheme[parser-tools/lex] library. get-token must obey the following invariants: @itemize[ @@ -44,7 +50,7 @@ Every position in the buffer must be accounted for in exactly one token.} @item{ - The token returned by get-token must rely only on the contents of the + The token returned by @scheme[get-token] must rely only on the contents of the input port argument. This means that the tokenization of some part of the input cannot depend on earlier parts of the input.} @item{ @@ -57,25 +63,25 @@ the buffer look like: @verbatim{" 1 2 3"} would result in a single string token modifying previous tokens. To - handle these situations, get-token must treat the first line as a + handle these situations, @scheme[get-token] must treat the first line as a single token.}] - @scheme[pairs] is a list of different kinds of matching parens. The second + The @scheme[pairs] argument is a list of different kinds of matching parens. The second value returned by get-token is compared to this list to see how the paren matcher should treat the token. An example: Suppose pairs is @scheme['((|(| |)|) (|[| |]|) (begin end))]. This means that there - are three kinds of parens. Any token which has 'begin as its second - return value will act as an open for matching tokens with 'end. + are three kinds of parens. Any token which has @scheme['begin] as its second + return value will act as an open for matching tokens with @scheme['end]. Similarly any token with @scheme['|]|] will act as a closing match for tokens with @scheme['|[|]. When trying to correct a mismatched closing parenthesis, each closing symbol in pairs will be converted to a string and tried as a closing parenthesis. } - @defmethod*[(((stop-colorer (clear-colors boolean |#t|)) void))]{ + @defmethod*[(((stop-colorer (clear-colors boolean #t)) void))]{ Stops coloring and paren matching the buffer. - If clear-colors is true all the text in the buffer will have it's + If @scheme[clear-colors] is true all the text in the buffer will have its style set to Standard. } @defmethod*[(((force-stop-colorer (stop? boolean?)) void))]{ @@ -83,7 +89,7 @@ Intended for debugging purposes only. - stop? determines whether the system is being forced to stop or allowed + @scheme[stop?] determines whether the system is being forced to stop or allowed to wake back up. } @defmethod*[(((is-stopped?) boolean?))]{ @@ -96,27 +102,25 @@ and @method[color:text<%> thaw-colorer]. - } @defmethod*[(((freeze-colorer) void))]{ Keep the text tokenized and paren matched, but stop altering the colors. - - freeze-colorer will not return until the coloring/tokenization of the + @scheme[freeze-colorer] will not return until the coloring/tokenization of the entire text is brought up-to-date. It must not be called on a locked text. } - @defmethod*[(((thaw-colorer (recolor boolean |#t|) (retokenize boolean |#f|)) void))]{ + @defmethod*[(((thaw-colorer (recolor boolean #t) (retokenize boolean #f)) void))]{ Start coloring a frozen buffer again. - If recolor? is @scheme[#t], the text is re-colored. If it is - @scheme[#f] the text is not recolored. When recolor? is @scheme[#t], - retokenize? controls how the text is recolored. @scheme[#f] causes + If @scheme[recolor?] is @scheme[#t], the text is re-colored. If it is + @scheme[#f] the text is not recolored. When @scheme[recolor?] is @scheme[#t], + @scheme[retokenize?] controls how the text is recolored. @scheme[#f] causes the text to be entirely re-colored before thaw-colorer returns using the existing tokenization. @scheme[#t] causes the entire text to be retokenized and recolored from scratch. This will happen in the - background after the call to thaw-colorer returns. + background after the call to @scheme[thaw-colorer] returns. } @defmethod*[(((reset-region (start natural-number?) (end (union (quote end) natural-number?))) void))]{ @@ -134,19 +138,16 @@ @defmethod*[(((skip-whitespace (position natural-number?) (direction (symbols (quote forward) (quote backward))) (comments? boolean?)) natural-number?))]{ Returns the next non-whitespace character. - Starts from position and skips whitespace in the direction indicated - by direction. If comments? is true, comments are skipped as well as + by direction. If @scheme[comments?] is true, comments are skipped as well as whitespace. skip-whitespace determines whitespaces and comments by - comparing the token type to 'white-space and 'comment. + comparing the token type to @scheme['white-space] and @scheme['comment]. Must only be called while the tokenizer is started. } @defmethod*[(((backward-match (position natural-number?) (cutoff natural-number?)) (union natural-number? false?)))]{ - - - Skip all consecutive whitespaces and comments (using skip-whitespace) + Skip all consecutive whitespaces and comments (using @scheme[skip-whitespace]) immediately preceding the position. If the token at this position is a close, return the position of the matching open, or @scheme[#f] if there is none. If the token was an open, return @scheme[#f]. For any @@ -163,9 +164,7 @@ } @defmethod*[(((forward-match (position natural-number?) (cutoff natural-number?)) (union natural-number? false?)))]{ - - - Skip all consecutive whitespaces and comments (using skip-whitespace) + Skip all consecutive whitespaces and comments (using @scheme[skip-whitespace]) immediately following position. If the token at this position is an open, return the position of the matching close, or @scheme[#f] if there is none. For any other token, return the end of that token. @@ -174,12 +173,11 @@ } @defmethod*[(((insert-close-paren (position natural-number?) (char char?) (flash? boolean?) (fixup? boolean?)) void))]{ - Position is the place to put the parenthesis and char is the - parenthesis to be added. If fixup? is true, the right kind of closing + parenthesis to be added. If @scheme[fixup?] is true, the right kind of closing parenthesis will be chosen from the pairs list kept last passed to - start-colorer, otherwise char will be inserted, even if it is not the - right kind. If flash? is true the matching open parenthesis will be + @scheme[start-colorer], otherwise char will be inserted, even if it is not the + right kind. If @scheme[flash?] is true the matching open parenthesis will be flashed. } @defmethod*[(((classify-position (position natural-number?)) symbol?))]{ @@ -218,7 +216,9 @@ @defmixin[color:text-mode-mixin (mode:surrogate-text<%>) (color:text-mode<%>)]{ This mixin adds coloring functionality to the mode. - @defconstructor[((get-token lexer default-lexer) (token-sym->style (token $rightarrow$ string) |scheme(λ (x) "Standard"))|) (matches (listof (list/c symbol? symbol?)) null))]{ + @defconstructor[((get-token lexer default-lexer) + (token-sym->style (symbol? . -> . string?) (λ (x) "Standard")) + (matches (listof (list/c symbol? symbol?)) null))]{ The arguments are passed to @method[color:text<%> start-colorer]. diff --git a/collects/scribblings/framework/scheme.scrbl b/collects/scribblings/framework/scheme.scrbl index e7f1c5bd3a..3534b8a1d3 100644 --- a/collects/scribblings/framework/scheme.scrbl +++ b/collects/scribblings/framework/scheme.scrbl @@ -57,7 +57,7 @@ The result of this method is used to determine if the return key automatically tabs over to the correct position. - Override it to change it's behavior. + Override it to change its behavior. } @@ -199,7 +199,7 @@ } @defmethod*[(((mark-matching-parenthesis (pos exact-positive-integer)) void))]{ If the paren after @scheme[pos] is matched, this method - highlights it and it's matching counterpart in dark green. + highlights it and its matching counterpart in dark green. } @defmethod*[(((get-tab-size) exact-integer))]{ diff --git a/collects/scribblings/gui/editor-intf.scrbl b/collects/scribblings/gui/editor-intf.scrbl index 2184550f83..99dc7b6fe3 100644 --- a/collects/scribblings/gui/editor-intf.scrbl +++ b/collects/scribblings/gui/editor-intf.scrbl @@ -1826,7 +1826,7 @@ See @method[editor<%> read-header-from-file]. @defmethod[(read-from-file [stream (is-a?/c editor-stream-in%)] - [overwrite-styles? any/c #t]) + [overwrite-styles? any/c #f]) boolean?]{ Reads new contents for the editor from a stream. The return value is diff --git a/collects/scribblings/gui/editor-stream-in-base-class.scrbl b/collects/scribblings/gui/editor-stream-in-base-class.scrbl index ce4cfc8952..77d66c3abc 100644 --- a/collects/scribblings/gui/editor-stream-in-base-class.scrbl +++ b/collects/scribblings/gui/editor-stream-in-base-class.scrbl @@ -37,6 +37,14 @@ Reads bytes to fill the supplied byte string. The return value is the next call to @method[editor-stream-in-base% bad?] must return @scheme[#t].} +@defmethod[(read-byte) (or/c byte? #f)]{ + +Reads a single byte and return it, or returns @scheme[#f] if no more +bytes are available. The default implementation of this method uses +@method[editor-stream-in-base% read-bytes]. + +} + @defmethod[(seek [pos exact-nonnegative-integer?]) void?]{ diff --git a/collects/scribblings/gui/editor-stream-in-class.scrbl b/collects/scribblings/gui/editor-stream-in-class.scrbl index 25f0e9647b..5d67b067d8 100644 --- a/collects/scribblings/gui/editor-stream-in-class.scrbl +++ b/collects/scribblings/gui/editor-stream-in-class.scrbl @@ -54,12 +54,18 @@ Returns the next integer value in the stream. @defmethod[(get-fixed [v (box/c (and/c exact? integer?))]) (is-a?/c editor-stream-in%)]{ +@boxisfill[(scheme v) @elem{a fixed-size integer from the stream obtained through + @method[editor-stream-in% get-fixed-exact]}] + +} + +@defmethod[(get-fixed-exact) + (and/c exact? integer?)]{ + Gets a fixed-sized integer from the stream. See @method[editor-stream-out% put-fixed] for more information. Reading from a bad stream always gives @scheme[0]. -@boxisfill[(scheme v) @elem{the fixed-size integer from the stream}] - } @defmethod[(get-inexact) diff --git a/collects/scribblings/gui/editor-stream-out-class.scrbl b/collects/scribblings/gui/editor-stream-out-class.scrbl index d869eaf23a..30bdb2b4ec 100644 --- a/collects/scribblings/gui/editor-stream-out-class.scrbl +++ b/collects/scribblings/gui/editor-stream-out-class.scrbl @@ -86,7 +86,8 @@ Puts a fixed-sized integer into the stream. This method is needed fixed-size number. Numbers written to a stream with @method[editor-stream-out% put-fixed] - must be read with @method[editor-stream-in% get-fixed].} + must be read with @method[editor-stream-in% get-fixed-exact] + or @method[editor-stream-in% get-fixed].} @defmethod[(put-unterminated [v bytes?]) (is-a?/c editor-stream-out%)]{ diff --git a/collects/scribblings/gui/text-class.scrbl b/collects/scribblings/gui/text-class.scrbl index 3635683ed6..d0af7be3fd 100644 --- a/collects/scribblings/gui/text-class.scrbl +++ b/collects/scribblings/gui/text-class.scrbl @@ -1698,7 +1698,7 @@ Returns the paragraph number of the paragraph containing a given @techlink{posit @defmethod[#:mode extend (read-from-file [stream (is-a?/c editor-stream-in%)] [start (or/c exact-nonnegative-integer? (one/of 'start))] - [overwrite-styles? any/c #t]) + [overwrite-styles? any/c #f]) boolean?]{ New data is inserted at the @techlink{position} indicated by @scheme[start], or at diff --git a/collects/scribblings/guide/contracts-simple-function.scrbl b/collects/scribblings/guide/contracts-simple-function.scrbl index 60f6ac2d79..437f38647e 100644 --- a/collects/scribblings/guide/contracts-simple-function.scrbl +++ b/collects/scribblings/guide/contracts-simple-function.scrbl @@ -78,7 +78,7 @@ argument and for the result. When all you have, however, is a Scheme name, such as @scheme[create] or @scheme[deposit], you want to tell the reader what the name represents (a function) and, if it is a function (or some other complex value) what the pieces are supposed to be. This is why -we use a @scheme[->] to say "hey, expect this to be a function." +we use a @scheme[->] to say ``hey, expect this to be a function.'' So @scheme[->] says ``this is a contract for a function.'' What follows in a function contracts are contracts (sub-contracts if you wish) that tell @@ -93,8 +93,8 @@ number, and a boolean. Its result is an account. In short, the arrow @scheme[->] is a @italic{contract combinator}. Its purpose is to combine other contracts into a contract -that says "this is a function @italic{and} its arguments and its result are -like that." +that says ``this is a function @italic{and} its arguments and its result +are like that.'' @ctc-section[#:tag "dots"]{Infix Contract Notation} @@ -219,7 +219,7 @@ scheme (define (has-decimal? str) (define L (string-length str)) (and (>= L 3) - (char=? #\. (string-ref result (- L 3))))) + (char=? #\. (string-ref str (- L 3))))) (provide/contract (code:comment "convert a random number to a string") @@ -253,15 +253,15 @@ scheme (define (has-decimal? str) (define L (string-length str)) (and (>= L 3) - (char=? #\. (string-ref result (- L 3))))) + (char=? #\. (string-ref str (- L 3))))) (define (is-decimal-string? str) (define L (string-length str)) (and (has-decimal? str) (andmap digit-char? - (string->list (substring result 0 (- L 3)))) + (string->list (substring str 0 (- L 3)))) (andmap digit-char? - (string->list (substring result (- L 2) L))))) + (string->list (substring str (- L 2) L))))) (provide/contract ... diff --git a/collects/scribblings/guide/simple-data.scrbl b/collects/scribblings/guide/simple-data.scrbl index 1272860289..933debcfdf 100644 --- a/collects/scribblings/guide/simple-data.scrbl +++ b/collects/scribblings/guide/simple-data.scrbl @@ -15,10 +15,9 @@ and imaginary numbers: @moreguide["numbers"]{numbers} @schemeblock[ -1 1.0 -1/2 0.5 -9999999999999999999999 1e+22 -1+2i 1.0+2.0i +1 3.14 +1/2 6.02e+23 +1+2i 9999999999999999999999 ] @defterm{Booleans} are @scheme[#t] for true and @scheme[#f] for @@ -36,8 +35,8 @@ appear in a string constant. @moreguide["strings"]{strings} @schemeblock[ -"hello world" -"A \"fancy\" string" +"Hello, world!" +"Benjamin \"Bugsy\" Siegel" "\u03BBx:(\u03BC\u03B1.\u03B1\u2192\u03B1).xx" ] @@ -49,5 +48,5 @@ difference between an input expression and a printed result. @examples[ (eval:alts (unsyntax (schemevalfont "1.0000")) 1.0000) -(eval:alts (unsyntax (schemevalfont "\"A \\u0022fancy\\u0022 string\"")) "A \u0022fancy\u0022 string") +(eval:alts (unsyntax (schemevalfont "\"Bugs \\u0022Figaro\\u0022 Bunny\"")) "Bugs \u0022Figaro\u0022 Bunny") ] diff --git a/collects/scribblings/guide/simple-syntax.scrbl b/collects/scribblings/guide/simple-syntax.scrbl index 924880fe0d..5d949d9b45 100644 --- a/collects/scribblings/guide/simple-syntax.scrbl +++ b/collects/scribblings/guide/simple-syntax.scrbl @@ -81,11 +81,11 @@ the last @nonterm{expr}. @defexamples[ #:eval ex-eval -(code:line (define five 5) (code:comment #, @t{defines @scheme[five] to be @scheme[5]})) +(code:line (define pie 3) (code:comment #, @t{defines @scheme[pie] to be @scheme[3]})) (code:line (define (piece str) (code:comment #, @t{defines @scheme[piece] as a function}) - (substring str 0 five)) (code:comment #, @t{of one argument})) -five -(piece "hello world") + (substring str 0 pie)) (code:comment #, @t{ of one argument})) +pie +(piece "key lime") ] Under the hood, a function definition is really the same as a @@ -100,8 +100,6 @@ piece substring ] -@; FIXME: check that everything says "procedure" and not "primitive" - A function definition can include multiple expressions for the function's body. In that case, only the value of the last expression is returned when the function is called. The other expressions are @@ -109,30 +107,30 @@ evaluated only for some side-effect, such as printing. @defexamples[ #:eval ex-eval -(define (greet name) - (printf "returning a greeting for ~a...\n" name) - (string-append "hello " name)) -(greet "universe") +(define (bake flavor) + (printf "pre-heating oven...\n") + (string-append flavor " pie")) +(bake "apple") ] -Scheme programmers prefer to avoid assignment statements. It's +Scheme programmers prefer to avoid side-effects. It's important, though, to understand that multiple expressions are allowed in a definition body, because it explains why the following -@scheme[nogreet] function simply returns its argument: +@scheme[nobake] function simply returns its argument: @def+int[ #:eval ex-eval -(define (nogreet name) - string-append "hello " name) -(nogreet "world") +(define (nobake flavor) + string-append flavor "jello") +(nobake "green") ] -Within @scheme[nogreet], there are no parentheses around -@scheme[string-append "hello " name], so they are three separate +Within @scheme[nobake], there are no parentheses around +@scheme[string-append flavor "jello"], so they are three separate expressions instead of one function-call expression. The expressions -@scheme[string-append] and @scheme["hello "] are evaluated, but the +@scheme[string-append] and @scheme[flavor] are evaluated, but the results are never used. Instead, the result of the function is just -the result of the expression @scheme[name]. +the result of the final expression, @scheme["jello"]. @; ---------------------------------------------------------------------- @section[#:tag "indentation"]{An Aside on Indenting Code} @@ -161,13 +159,14 @@ next line under the first argument, instead of under the @scheme[define] keyword: @schemeblock[ -(define (nogreet name - (string-append "hello " name))) +(define (halfbake flavor + (string-append flavor " creme brulee"))) ] -Furthermore, when an open parenthesis has no matching close -parenthesis in a program, both @exec{mzscheme} and DrScheme use the -source's indentation to suggest where it might be missing. +In this case, indentation helps highlight the mistake. In other cases, +where the indentation may be normal while an open parenthesis has no +matching close parenthesis; both @exec{mzscheme} and DrScheme use the +source's indentation to suggest where a parenthesis might be missing. @;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @section{Identifiers} @@ -193,11 +192,11 @@ more examples: @schemeblock[ #, @schemeid[+] -#, @schemeid[Apple] +#, @schemeid[Hfuhruhurr] #, @schemeid[integer?] -#, @schemeid[call/cc] -#, @schemeid[call-with-composable-continuation] -#, @schemeid[x-1+3i] +#, @schemeid[pass/fail] +#, @schemeid[john-jacob-jingleheimer-schmidt] +#, @schemeid[a-b-c+1-2-3] ] @;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -225,10 +224,10 @@ pre-defined names are hyperlinked to the reference manual. So, you can click on an identifier to get full details about its use. @interaction[ -(code:line (string-append "hello" " " "scheme") (code:comment #, @t{append strings})) -(code:line (substring "hello scheme" 6 12) (code:comment #, @t{extract a substring})) -(code:line (string-length "scheme") (code:comment #, @t{get a string's length})) -(code:line (string? "hello scheme") (code:comment #, @t{recognize strings})) +(code:line (string-append "rope" "twine" "yarn") (code:comment #, @t{append strings})) +(code:line (substring "corduroys" 0 4) (code:comment #, @t{extract a substring})) +(code:line (string-length "shoelace") (code:comment #, @t{get a string's length})) +(code:line (string? "c'est ne pas une string") (code:comment #, @t{recognize strings})) (string? 1) (code:line (sqrt 16) (code:comment #, @t{find a square root})) (sqrt -16) @@ -236,10 +235,11 @@ click on an identifier to get full details about its use. (code:line (- 2 1) (code:comment #, @t{subtract numbers})) (code:line (< 2 1) (code:comment #, @t{compare numbers})) (>= 2 1) -(code:line (number? "hello scheme") (code:comment #, @t{recognize numbers})) +(code:line (number? "c'est une number") (code:comment #, @t{recognize numbers})) (number? 1) -(code:line (equal? 1 "hello") (code:comment #, @t{compare anything})) -(equal? 1 1) +(code:line (equal? 6 "half dozen") (code:comment #, @t{compare anything})) +(equal? 6 6) +(equal? "half dozen" "half dozen") ] @;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -403,7 +403,7 @@ expression: @def+int[ (define (double v) ((if (string? v) string-append +) v v)) -(double "hello") +(double "mnah") (double 5) ] @@ -581,9 +581,12 @@ each clause, the @nonterm{id} is bound to the result of the @nonterm{expr} for use in the body. @interaction[ -(let ([x 1] - [y 2]) - (format "adding ~s and ~s produces ~s" x y (+ x y))) +(let ([x (random 4)] + [o (random 4)]) + (cond + [(> x o) "X wins"] + [(> o x) "O wins"] + [else "cat's game"])) ] The bindings of a @scheme[let] form are available only in the body of @@ -592,10 +595,13 @@ other. The @scheme[let*] form, in contrast, allows later clauses to use earlier bindings: @interaction[ -(let* ([x 1] - [y 2] - [z (+ x y)]) - (format "adding ~s and ~s produces ~s" x y z)) +(let* ([x (random 4)] + [o (random 4)] + [diff (number->string (abs (- x o)))]) + (cond + [(> x o) (string-append "X wins by " diff)] + [(> o x) (string-append "O wins by " diff)] + [else "cat's game"])) ] @; ---------------------------------------------------------------------- diff --git a/collects/scribblings/guide/welcome.scrbl b/collects/scribblings/guide/welcome.scrbl index ef3b7316ee..e924f9b841 100644 --- a/collects/scribblings/guide/welcome.scrbl +++ b/collects/scribblings/guide/welcome.scrbl @@ -2,7 +2,8 @@ @(require scribble/manual scribble/eval scribble/bnf - "guide-utils.ss") + "guide-utils.ss" + (for-label scheme/enter)) @(define piece-eval (make-base-eval)) @@ -85,16 +86,16 @@ number: A string is also an expression that evaluates to itself. A string is written with double quotes at the start and end of the string: -@interaction["hello world"] +@interaction["Hello, world!"] Scheme uses parentheses to wrap larger expressions---almost any kind of expression, other than simple constants. For example, a function call is written: open parenthesis, function name, argument expression, and closing parenthesis. The following expression calls the built-in function @scheme[substring] with the arguments -@scheme["hello world"], @scheme[0], and @scheme[5]: +@scheme["the boy out of the country"], @scheme[4], and @scheme[7]: -@interaction[(substring "hello world" 0 5)] +@interaction[(substring "the boy out of the country" 4 7)] @; ---------------------------------------------------------------------- @section{Definitions and Interactions} @@ -104,9 +105,10 @@ using the @scheme[define] form, like this: @def+int[ #:eval piece-eval -(define (piece str) - (substring str 0 5)) -(piece "howdy universe") +(define (extract str) + (substring str 4 7)) +(extract "the boy out of the country") +(extract "the country out of the boy") ] Although you can evaluate the @scheme[define] form in the @tech{REPL}, @@ -118,29 +120,29 @@ top text area---called the @deftech{definitions area}---along with the @schememod[ scheme code:blank -(define (piece str) - (substring str 0 5)) +(define (extract str) + (substring str 4 7)) ] -If calling @scheme[(piece "howdy universe")] is part of the main -action of your program, that would go in the @tech{definitions area}, -too. But if it was just an example expression that you were using to -explore @scheme[piece], then you'd more likely leave the -@tech{definitions area} as above, click @onscreen{Run}, and then -evaluate @scheme[(piece "howdy universe")] in the @tech{REPL}. +If calling @scheme[(extract "the boy")] is part of the main action of +your program, that would go in the @tech{definitions area}, too. But +if it was just an example expression that you were using to explore +@scheme[extract], then you'd more likely leave the @tech{definitions +area} as above, click @onscreen{Run}, and then evaluate +@scheme[(extract "the boy")] in the @tech{REPL}. With @exec{mzscheme}, you'd save the above text in a file using your -favorite editor. If you save it as @filepath{piece.ss}, then after starting +favorite editor. If you save it as @filepath{extract.ss}, then after starting @exec{mzscheme} in the same directory, you'd evaluate the following sequence: @interaction[ #:eval piece-eval -(eval:alts (enter! "piece.ss") (void)) -(piece "howdy universe") +(eval:alts (enter! "extract.ss") (void)) +(extract "the gal out of the city") ] -The @scheme[enter!] function both loads the code and switches the +The @scheme[enter!] form both loads the code and switches the evaluation context to the inside of the module, just like DrScheme's @onscreen{Run} button. @@ -152,13 +154,13 @@ If your file (or @tech{definitions area} in DrScheme) contains @schememod[ scheme -(define (piece str) - (substring str 0 5)) +(define (extract str) + (substring str 4 7)) -(piece "howdy universe") +(extract "the cat out of the bag") ] -then it is a complete program that prints ``howdy'' when run. To +then it is a complete program that prints ``cat'' when run. To package this program as an executable, choose one of the following options: @@ -200,16 +202,16 @@ If you already know something about Scheme or Lisp, you might be tempted to put just @schemeblock[ -(define (piece str) - (substring str 0 5)) +(define (extract str) + (substring str 4 7)) ] -into @filepath{piece.scm} and run @exec{mzscheme} with +into @filepath{extract.scm} and run @exec{mzscheme} with @interaction[ #:eval piece-eval -(eval:alts (load "piece.scm") (void)) -(piece "howdy universe") +(eval:alts (load "extract.scm") (void)) +(extract "the dog out") ] That will work, because @exec{mzscheme} is willing to imitate a diff --git a/collects/scribblings/htdp-langs/advanced.scrbl b/collects/scribblings/htdp-langs/advanced.scrbl index 16cf810683..096116d584 100644 --- a/collects/scribblings/htdp-langs/advanced.scrbl +++ b/collects/scribblings/htdp-langs/advanced.scrbl @@ -4,18 +4,24 @@ "prim-ops.ss" (for-label lang/htdp-advanced)) -@(define-syntax-rule (bd intm-define intm-define-struct intm-lambda intm-local intm-letrec intm-let intm-let* intm-time) +@(define-syntax-rule (bdl intm-define intm-lambda) + (begin + (require (for-label lang/htdp-intermediate-lambda)) + (define intm-define (scheme define)) + (define intm-lambda (scheme lambda)))) +@(bdl intm-define intm-lambda) + +@(define-syntax-rule (bd intm-define-struct intm-local intm-letrec intm-let intm-let* intm-time) (begin (require (for-label lang/htdp-intermediate)) (define intm-define (scheme define)) (define intm-define-struct (scheme define-struct)) - (define intm-lambda (scheme lambda)) (define intm-local (scheme local)) (define intm-letrec (scheme letrec)) (define intm-let (scheme let)) (define intm-let* (scheme let*)) (define intm-time (scheme time)))) -@(bd intm-define intm-define-struct intm-lambda intm-local intm-letrec intm-let intm-let* intm-time) +@(bd intm-define-struct intm-local intm-letrec intm-let intm-let* intm-time) @(define-syntax-rule (bbd beg-define beg-define-struct beg-cond beg-if beg-and beg-or beg-check-expect beg-require) (begin @@ -36,7 +42,7 @@ @declare-exporting[lang/htdp-advanced] @schemegrammar*+qq[ -#:literals (define define-struct lambda cond else if and or empty true false require lib planet +#:literals (define define-struct lambda λ cond else if and or empty true false require lib planet local let let* letrec time begin begin0 set! delay shared recur when case unless check-expect check-within check-error) (check-expect check-within check-error require) @@ -53,6 +59,7 @@ (set! id expr) (delay expr) (lambda (id ...) expr) + (λ (id ...) expr) (local [definition ...] expr) (letrec ([id expr] ...) expr) (shared ([id expr] ...) expr) @@ -126,7 +133,10 @@ additional set of operations: @section[#:tag "advanced-lambda"]{@scheme[lambda]} -@defform[(lambda (id ...) expr)]{ +@deftogether[( +@defform[(lambda (id ...) expr)] +@defform[(λ (id ...) expr)] +)]{ The same as Intermediate with Lambda's @|intm-lambda|, except that a function is allowed to accept zero arguments.} diff --git a/collects/scribblings/htdp-langs/intermediate-lambda.scrbl b/collects/scribblings/htdp-langs/intermediate-lambda.scrbl index f3c63795ce..35218faadc 100644 --- a/collects/scribblings/htdp-langs/intermediate-lambda.scrbl +++ b/collects/scribblings/htdp-langs/intermediate-lambda.scrbl @@ -35,7 +35,7 @@ @declare-exporting[lang/htdp-intermediate-lambda] @schemegrammar*+qq[ -#:literals (define define-struct lambda cond else if and or empty true false require lib planet +#:literals (define define-struct lambda λ cond else if and or empty true false require lib planet local let let* letrec time check-expect check-within check-error) (check-expect check-within check-error require) [program (code:line def-or-expr ...)] @@ -47,6 +47,7 @@ (define id expr) (define-struct id (id ...))] [expr (lambda (id id ...) expr) + (λ (id id ...) expr) (local [definition ...] expr) (letrec ([id expr] ...) expr) (let ([id expr] ...) expr) @@ -97,6 +98,10 @@ for @scheme[lambda], since a @scheme[lambda] form is an expression.} Creates a function that takes as many arguments as given @scheme[id]s, and whose body is @scheme[expr].} +@defform[(λ (id id ...) expr)]{ + +The Greek letter @scheme[λ] is a synonym for @scheme[lambda].} + @; ---------------------------------------------------------------------- @section[#:tag "intermediate-lambda-call"]{Function Calls} diff --git a/collects/scribblings/inside/ports.scrbl b/collects/scribblings/inside/ports.scrbl index bb6ffc0f2d..4c8be45ac3 100644 --- a/collects/scribblings/inside/ports.scrbl +++ b/collects/scribblings/inside/ports.scrbl @@ -463,9 +463,9 @@ The functions are as follows. Called to obtain a progress event for the port, such as for @scheme[port-progress-evt]. This function can be @cpp{NULL} if the port does not support progress events. Use - @cpp{progress_evt_via_get} to obtain a default implementation, in + @cpp{scheme_progress_evt_via_get} to obtain a default implementation, in which case @var{peeked_read_fun} should be - @cpp{peeked_read_via_get}, and @var{get_bytes_fun} and + @cpp{scheme_peeked_read_via_get}, and @var{get_bytes_fun} and @var{peek_bytes_fun} should handle @var{unless} as described above.} @@ -477,9 +477,9 @@ The functions are as follows. Called to commit previously peeked bytes, just like the sixth argument to @scheme[make-input-port]. Use - @cpp{peeked_read_via_get} for the default implementation of + @cpp{scheme_peeked_read_via_get} for the default implementation of commits when @var{progress_evt_fun} is - @cpp{progress_evt_via_get}.} + @cpp{scheme_progress_evt_via_get}.} @subfunction[(int char_ready_fun [Scheme_Input_Port* port])]{ diff --git a/collects/scribblings/mzc/zo-parse.scrbl b/collects/scribblings/mzc/zo-parse.scrbl index f5b1c2ef81..60e53074a1 100644 --- a/collects/scribblings/mzc/zo-parse.scrbl +++ b/collects/scribblings/mzc/zo-parse.scrbl @@ -14,7 +14,7 @@ @defproc[(zo-parse [in input-port?]) compilation-top?]{ Parses a port (typically the result of opening a @filepath{.zo} file) -containing byte. Beware that the structure types used to represent the +containing bytecode. Beware that the structure types used to represent the bytecode are subject to frequent changes across PLT Scheme versons. The parsed bytecode is returned in a @scheme[compilation-top] @@ -23,7 +23,7 @@ structure will contain a @scheme[mod] structure. For a top-level sequence, it will normally contain a @scheme[seq] or @scheme[splice] structure with a list of top-level declarations and expressions. -The bytecode representation f an expression is closer to an +The bytecode representation of an expression is closer to an S-expression than a traditional, flat control string. For example, an @scheme[if] form is represented by a @scheme[branch] structure that has three fields: a test expression, a ``then'' expression, and an diff --git a/collects/scribblings/reference/pairs.scrbl b/collects/scribblings/reference/pairs.scrbl index c06b1bcfad..cc60d0af62 100644 --- a/collects/scribblings/reference/pairs.scrbl +++ b/collects/scribblings/reference/pairs.scrbl @@ -146,7 +146,7 @@ must merely start with a chain of at least @scheme[pos] pairs.} @defproc*[([(append [lst list?] ...) list?] [(append [lst list?] ... [v any/c]) any/c])]{ -When given all list arguments, the result is a lists that contains all +When given all list arguments, the result is a list that contains all of the elements of the given lists in order. The last argument is used directly in the tail of the result. @@ -211,10 +211,10 @@ Similar to @scheme[map], except that @item{the result of the first applciation of @scheme[proc] to produces a value other than @scheme[#f], in which case @scheme[proc] is not - applied to later elements of the @scheme[lst]s; more specifically, + applied to later elements of the @scheme[lst]s; the application of @scheme[proc] to the last elements in the @scheme[lst]s is in tail position with respect to the - @scheme[andmap] call.} + @scheme[ormap] call.} ] diff --git a/collects/scribblings/reference/sequences.scrbl b/collects/scribblings/reference/sequences.scrbl index abf63cc2ab..609c5c7ee6 100644 --- a/collects/scribblings/reference/sequences.scrbl +++ b/collects/scribblings/reference/sequences.scrbl @@ -147,7 +147,7 @@ opposed to using @scheme[in] directly as a sequence to get bytes).} sequence?]{ Returns a sequence whose elements are the result of @scheme[(read-line -in mode)] until an end-of-line is encountered. Note that the default +in mode)] until an end-of-file is encountered. Note that the default mode is @scheme['any], whereas the default mode of @scheme[read-line] is @scheme['linefeed].} diff --git a/collects/scribblings/reference/startup.scrbl b/collects/scribblings/reference/startup.scrbl index d52f96e153..c399259ade 100644 --- a/collects/scribblings/reference/startup.scrbl +++ b/collects/scribblings/reference/startup.scrbl @@ -138,7 +138,11 @@ flags: @item{@FlagFirst{p} @nonterm{file} @nonterm{u} @nonterm{path} : @scheme[require]s @scheme[(planet #, @nontermstr{file} - #, @nontermstr{user} #, @nontermstr{pkg})].} + #, @nontermstr{user} #, @nontermstr{pkg})]. + + @margin-note{Despite its name, @DFlag{script} is not usually + used for Unix scripts. See @guidesecref["scripts"] for more + information on scripts.}} @item{@FlagFirst{r} @nonterm{file} or @DFlagFirst{script} @nonterm{file} : @scheme[load]s @nonterm{file} as a diff --git a/collects/scribblings/reference/struct.scrbl b/collects/scribblings/reference/struct.scrbl index 554580ed8c..b4bb35bf2e 100644 --- a/collects/scribblings/reference/struct.scrbl +++ b/collects/scribblings/reference/struct.scrbl @@ -237,7 +237,8 @@ The result of @scheme[make-struct-type] is five values: @defproc[(make-struct-field-accessor [accessor-proc struct-accessot-procedure?] [field-pos exact-nonnegative-integer?] - [field-name symbol?]) + [field-name (or/c symbol? #f) + (symbol->string (format "field~a" field-pos))]) procedure?]{ Returns a field accessor that is equivalent to @scheme[(lambda (s) @@ -245,13 +246,14 @@ Returns a field accessor that is equivalent to @scheme[(lambda (s) an @tech{accessor} returned by @scheme[make-struct-type]. The name of the resulting procedure for debugging purposes is derived from @scheme[field-name] and the name of @scheme[accessor-proc]'s -structure type. +structure type if @scheme[field-name] is a symbol. For examples, see @scheme[make-struct-type].} @defproc[(make-struct-field-mutator [mutator-proc struct-mutator-procedure?] [field-pos exact-nonnegative-integer?] - [field-name symbol?]) + [field-name (or/c symbol? #f) + (symbol->string (format "field~a" field-pos))]) procedure?]{ Returns a field mutator that is equivalent to @scheme[(lambda (s v) @@ -259,7 +261,7 @@ Returns a field mutator that is equivalent to @scheme[(lambda (s v) a @tech{mutator} returned by @scheme[make-struct-type]. The name of the resulting procedure for debugging purposes is derived from @scheme[field-name] and the name of @scheme[mutator-proc]'s -structure type. +structure type if @scheme[field-name] is a symbol. For examples, see @scheme[make-struct-type].} diff --git a/collects/scribblings/reference/stx-props.scrbl b/collects/scribblings/reference/stx-props.scrbl index 8dd07e630d..d2dbc68450 100644 --- a/collects/scribblings/reference/stx-props.scrbl +++ b/collects/scribblings/reference/stx-props.scrbl @@ -54,17 +54,17 @@ MzScheme adds properties to expanded syntax (often using @item{When an internal @scheme[define-values] or @scheme[define-syntaxes] form is converted into a - @scheme[letrec-values+syntaxes] form (see @secref["intdef-body"]), + @scheme[letrec-syntaxes+values] form (see @secref["intdef-body"]), @scheme[syntax-track-origin] is applied to each generated binding clause. The second argument to @scheme[syntax-track-origin] is the converted form, and the third argument is the @scheme[define-values] or @scheme[define-syntaxes] keyword form the converted form.} - @item{When a @scheme[letrec-values+syntaxes] expression is fully + @item{When a @scheme[letrec-syntaxes+values] expression is fully expanded, syntax bindings disappear, and the result is either a @scheme[letrec-values] form (if the unexpanded form contained non-syntax bindings), or only the body of the - @scheme[letrec-values+syntaxes] form (wrapped with @scheme[begin] if + @scheme[letrec-syntaxes+values] form (wrapped with @scheme[begin] if the body contained multiple expressions). To record the disappeared syntax bindings, a property is added to the expansion result: an immutable list of identifiers from the disappeared bindings, as a diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index 856d6714f8..7d5c629922 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -976,11 +976,51 @@ sets of imported identifiers. @defform[(matching-identifiers-in regexp require-spec)]{ Like @scheme[require-spec], but including only imports whose names match @scheme[regexp]. The @scheme[regexp] must be a literal regular - expression (see @secref["regexp"]).} + expression (see @secref["regexp"]). + +@defexamples[#:eval (syntax-eval) +(module zoo scheme/base + (provide tunafish swordfish blowfish + monkey lizard ant) + (define tunafish 1) + (define swordfish 2) + (define blowfish 3) + (define monkey 4) + (define lizard 5) + (define ant 6)) +(require scheme/require) +(require (matching-identifiers-in #rx"\\w*fish" 'zoo)) +tunafish +swordfish +blowfish +monkey +]} @defform[(subtract-in require-spec subtracted-spec ...)]{ Like @scheme[require-spec], but omitting those imports that would be - imported by one of the @scheme[subtracted-spec]s.} + imported by one of the @scheme[subtracted-spec]s. + +@defexamples[#:eval (syntax-eval) +(module earth scheme + (provide land sea air) + (define land 1) + (define sea 2) + (define air 3)) + +(module mars scheme + (provide aliens) + (define aliens 4)) + +(module solar-system scheme + (require 'earth 'mars) + (provide (all-from-out 'earth) + (all-from-out 'mars))) + +(require scheme/require) +(require (subtract-in 'solar-system 'earth)) +land +aliens +]} @defform[(filtered-in proc-expr require-spec)]{ The @scheme[proc-expr] should evaluate to a single-argument procedure, which is applied on diff --git a/collects/scribblings/scribble/config.scrbl b/collects/scribblings/scribble/config.scrbl index a27f064e1f..af22fb0779 100644 --- a/collects/scribblings/scribble/config.scrbl +++ b/collects/scribblings/scribble/config.scrbl @@ -43,12 +43,15 @@ When a string is uses as a style in an @scheme[element], @scheme[styled-paragraph], @scheme[table], @scheme[styled-itemization], or @scheme[blockquote], it corresponds to a CSS class for HTML output or a Tex macro/environment for Latex -output. In Latex output, the string is used as a macro name for a +output. In Latex output, the string is used as a command name for a @scheme[styled-paragraph] and an environment name for a -@scheme[table], @scheme[itemization], or @scheme[blockquote]. In -addition, for an itemization, the style string is suffixed with -@scheme["Item"] and used as a CSS class or Tex macro name to use for -the itemization's items (in place of @tt{item} in the case of Latex). +@scheme[table], @scheme[itemization], or @scheme[blockquote], except +that a @scheme[blockquote] style name that starts with @litchar{\} is +used (sans @litchar{\}) as a command instead of an environment. +In addition, for an itemization, the style string is +suffixed with @scheme["Item"] and used as a CSS class or Tex macro +name to use for the itemization's items (in place of @tt{item} in the +case of Latex). Scribble includes a number of predefined styles that are used by the exports of @scheme[scribble/manual], but they are not generally diff --git a/collects/scribblings/scribble/manual.scrbl b/collects/scribblings/scribble/manual.scrbl index ce2eb65ca3..6057726ee4 100644 --- a/collects/scribblings/scribble/manual.scrbl +++ b/collects/scribblings/scribble/manual.scrbl @@ -1140,8 +1140,8 @@ centered table with the @scheme[pre-flow] parsed by @defproc[(commandline [pre-content any/c] ...) paragraph?]{Produces an inset command-line example (e.g., in typewriter font).} -@defproc[(margin-note [pre-content any/c] ...) paragraph?]{Produces -a paragraph to be typeset in the margin instead of inlined.} +@defproc[(margin-note [pre-content any/c] ...) blockquote?]{Produces +a @tech{blockquote} to be typeset in the margin instead of inlined.} @; ------------------------------------------------------------------------ @section[#:tag "index-entries"]{Index-Entry Descriptions} diff --git a/collects/scribblings/scribble/struct.scrbl b/collects/scribblings/scribble/struct.scrbl index 34b71f2cec..bc0a15666a 100644 --- a/collects/scribblings/scribble/struct.scrbl +++ b/collects/scribblings/scribble/struct.scrbl @@ -476,7 +476,8 @@ The @scheme[style] can be A @techlink{blockquote} has a style and a list of @tech{blocks}. The @scheme[style] field is normally a string that corresponds to a CSS -class for HTML output or Latex environment for Latex output (see +class for HTML output or Latex environment for Latex output where a +leading @litchar{\} in the style name is treated specially (see @secref["extra-style"]). } diff --git a/collects/slideshow/pict.ss b/collects/slideshow/pict.ss index 7c2fb925be..7b32fe8013 100644 --- a/collects/slideshow/pict.ss +++ b/collects/slideshow/pict.ss @@ -42,7 +42,7 @@ (list? p) (andmap pict? p)))) - (define (pin-line sz p + (define (pin-line p src src-find dest dest-find #:start-angle [sa #f] #:end-angle [ea #f] @@ -57,7 +57,7 @@ dest dest-find)) p lw col under?) (pin-curve* #f #f p src src-find dest dest-find - sa ea sp ep sz col lw under? #t))) + sa ea sp ep 0 col lw under? #t))) (define (pin-arrow-line sz p src src-find diff --git a/collects/string-constants/german-string-constants.ss b/collects/string-constants/german-string-constants.ss index eb67b339f9..2280eb68d0 100644 --- a/collects/string-constants/german-string-constants.ss +++ b/collects/string-constants/german-string-constants.ss @@ -1152,6 +1152,7 @@ (stepper-next "Schritt >") (stepper-next-application "Applikation >|") (stepper-jump-to-end "Ende") + (stepper-jump "Springen zu ...") (debug-tool-button-name "Debugger") diff --git a/collects/syntax/flatten-begin.ss b/collects/syntax/flatten-begin.ss new file mode 100644 index 0000000000..5cb4b0e5b5 --- /dev/null +++ b/collects/syntax/flatten-begin.ss @@ -0,0 +1,13 @@ +#lang scheme/base +(provide flatten-begin) + +(define (flatten-begin stx) + (let ([l (syntax->list stx)]) + (if l + (map (lambda (e) + (syntax-track-origin e stx (car l))) + (cdr l)) + (raise-syntax-error + #f + "bad syntax" + stx)))) diff --git a/collects/syntax/modresolve.ss b/collects/syntax/modresolve.ss index de53caf42b..fe5972a000 100644 --- a/collects/syntax/modresolve.ss +++ b/collects/syntax/modresolve.ss @@ -7,6 +7,9 @@ (cond [(path-string? relto) (if dir? (let-values ([(base n d?) (split-path relto)]) + (when d? + (error 'resolve-module-path-index + "given a directory path instead of a file path: ~e" relto)) (if (eq? base 'relative) (or (current-load-relative-directory) (current-directory)) base)) diff --git a/collects/syntax/scribblings/flatten-begin.scrbl b/collects/syntax/scribblings/flatten-begin.scrbl new file mode 100644 index 0000000000..c3f93313b8 --- /dev/null +++ b/collects/syntax/scribblings/flatten-begin.scrbl @@ -0,0 +1,14 @@ +#lang scribble/doc +@(require "common.ss" + (for-label syntax/flatten-begin)) + +@title[#:tag "flatten-begin"]{Flattening @scheme[begin] Forms} + +@defmodule[syntax/flatten-begin] + +@defproc[(flatten-begin [stx syntax?]) (listof syntax?)]{ + +Extracts the sub-expressions from a @scheme[begin]-like form, +reporting an error if @scheme[stx] does not have the right shape +(i.e., a syntax list). The resulting syntax objects have annotations +transferred from @scheme[stx] using @scheme[syntax-track-origin].} diff --git a/collects/syntax/scribblings/transformer-helpers.scrbl b/collects/syntax/scribblings/transformer-helpers.scrbl index 6f8aa521cb..951c202743 100644 --- a/collects/syntax/scribblings/transformer-helpers.scrbl +++ b/collects/syntax/scribblings/transformer-helpers.scrbl @@ -6,6 +6,6 @@ @include-section["name.scrbl"] @include-section["context.scrbl"] @include-section["define.scrbl"] +@include-section["flatten-begin.scrbl"] @include-section["struct.scrbl"] @include-section["path-spec.scrbl"] - diff --git a/collects/tests/honu/basic.honu b/collects/tests/honu/basic.honu index b05716e989..e5a22358cd 100644 --- a/collects/tests/honu/basic.honu +++ b/collects/tests/honu/basic.honu @@ -13,7 +13,45 @@ obj test(t, a, b){ } } -var x = 3; -const y = 2; -test("x = 3", x, 3); -test("y = 2", y, 2); +obj test1(){ + var x = 3; + const y = 2; + test("x = 3", x, 3); + test("y = 2", y, 2); +} + +obj test2(){ + obj foo(){ + 1; + } + + obj x1(){ + obj x(){ + 2; + } + x; + } + + (-> obj) x2(){ + obj x(){ + 3; + } + x; + } + + /* + var anonymous_foo = obj x(){ + 2; + }; + */ + + var anonymous_foo = x1(); + var x2_x = x2(); + + test("foo() = 1", foo(), 1); + test("anonymous_foo = 2", anonymous_foo(), 2); + test("x2_x = 3", x2_x(), 3); +} + +test1(); +test2(); diff --git a/collects/tests/mred/wxme.ss b/collects/tests/mred/wxme.ss index 3870cd3b20..869d90c448 100644 --- a/collects/tests/mred/wxme.ss +++ b/collects/tests/mred/wxme.ss @@ -768,12 +768,15 @@ (expect (send fi2 tell) 10) (send fi2 jump-to 3) -(send fi2 set-boundary 5) +(send fi2 set-boundary 2) (expect (send fi2 get-unterminated-bytes) #"hi") (send fi2 jump-to 3) (expect (send fi2 ok?) #t) -(send fi2 set-boundary 4) -(expect (send fi2 get-unterminated-bytes) #"") +(expect (send fi2 tell) 3) +(send fi2 set-boundary 1) +(expect (with-handlers ([values (lambda (exn) #"")]) + (send fi2 get-unterminated-bytes)) + #"") (expect (send fi2 ok?) #f) ;; ---------------------------------------- diff --git a/collects/tests/mzscheme/modprot.ss b/collects/tests/mzscheme/modprot.ss new file mode 100644 index 0000000000..64d03c0386 --- /dev/null +++ b/collects/tests/mzscheme/modprot.ss @@ -0,0 +1,212 @@ +(load-relative "loadtest.ss") + +(Section 'modprot) + +;; ============================================================ + +;; Use '#%kernel everywhere so we're only checking the directly +;; intended certifications and protections. + +(define zero + '(module zero '#%kernel + + (define-values (prot) 8) + + (#%provide (protect prot)))) + +;; - - - - - - - - - - - - - - - - - - - - + +(define one + '(module one '#%kernel + (#%require 'zero + (for-syntax '#%kernel)) + + (define-values (unexp) 5) + (define-syntaxes (stx) + (lambda (stx) (quote-syntax 13))) + + (define-syntaxes (nab) + (lambda (stx) + (datum->syntax + stx + (list (quote-syntax define-syntaxes) + (cdr (syntax-e stx)) + (quote-syntax (make-rename-transformer (quote-syntax unexp))))))) + (define-syntaxes (pnab) + (lambda (stx) + (datum->syntax + stx + (list (quote-syntax define-syntaxes) + (cdr (syntax-e stx)) + (quote-syntax (make-rename-transformer (quote-syntax prot))))))) + (define-syntaxes (snab) + (lambda (xstx) + (datum->syntax + xstx + (list (quote-syntax define-syntaxes) + (cdr (syntax-e xstx)) + (quote-syntax (make-rename-transformer (quote-syntax stx))))))) + + (#%provide nab + pnab + snab))) + +;; - - - - - - - - - - - - - - - - - - - - + +(define two/no-protect + '(module two '#%kernel + (#%require 'one) + + (define-values (normal) 10) + + (nab nabbed) + (pnab pnabbed) + (snab snabbed) + + (#%provide normal + nabbed + pnabbed + snabbed))) + +;; - - - - - - - - - - - - - - - - - - - - + +(define two/protect + '(module two '#%kernel + (#%require 'one) + + (define-values (normal) 10) + + (nab nabbed) + (pnab pnabbed) + (snab snabbed) + + (#%provide (protect normal + nabbed + pnabbed + snabbed)))) + +;; - - - - - - - - - - - - - - - - - - - - + +(define three/nabbed + '(module three '#%kernel + (#%module-begin + (#%require 'two) + (#%app printf "~s ~s\n" + (resolved-module-path-name + (module-path-index-resolve (car (identifier-binding (quote-syntax nabbed))))) + nabbed)))) + +;; - - - - - - - - - - - - - - - - - - - - + +(define three/pnabbed + '(module three '#%kernel + (#%module-begin + (#%require 'two) + (#%app printf "~s ~s\n" + (resolved-module-path-name + (module-path-index-resolve (car (identifier-binding (quote-syntax pnabbed))))) + pnabbed)))) + +;; - - - - - - - - - - - - - - - - - - - - + +(define three/snabbed + '(module three '#%kernel + (#%module-begin + (#%require 'two) + (#%app printf "~s ~s\n" + (resolved-module-path-name + (module-path-index-resolve (car (identifier-binding (quote-syntax snabbed))))) + snabbed)))) + +;; - - - - - - - - - - - - - - - - - - - - + +(define three/normal + '(module three '#%kernel + (#%module-begin + (#%require 'two) + (#%app printf "~s ~s\n" + (resolved-module-path-name + (module-path-index-resolve (car (identifier-binding (quote-syntax normal))))) + normal)))) + +;; - - - - - - - - - - - - - - - - - - - - + +(define (xeval e) + (eval + (if (bytes? e) + (parameterize ([read-accept-compiled #t]) + (read (open-input-bytes e))) + e))) + +(define (mp-try-all zero one two/no-protect two/protect three/nabbed three/pnabbed three/snabbed three/normal + get-one-inspector get-three-inspector fail-pnab? fail-prot? fail-three? np-ok?) + (let ([try + (lambda (two three v) + (let ([ns (make-base-namespace)] + [p (open-output-bytes)]) + (parameterize ([current-namespace ns] + [current-output-port p]) + (xeval zero) + (parameterize ([current-code-inspector (get-one-inspector)]) + (xeval one) + (xeval two) + (parameterize ([current-code-inspector (get-three-inspector)]) + (with-handlers ([(lambda (x) fail-three?) + (lambda (exn) + (printf "~a\n" (exn-message exn)))]) + (xeval three)) + (with-handlers ([values (lambda (exn) + (printf "~a\n" (exn-message exn)))]) + (eval '(#%require 'three)))))) + (test #t regexp-match? + (if (byte-regexp? v) v (byte-regexp (string->bytes/utf-8 (format "~a\n" v)))) + (get-output-bytes p))))]) + (try two/no-protect three/nabbed (if (and fail-prot? (not np-ok?)) #rx#"unexported .* unexp" #rx#"one 5")) + (try two/no-protect three/pnabbed (if (and fail-pnab? (not np-ok?)) #rx#"protected .* prot" #rx#"zero 8")) + (try two/no-protect three/snabbed #rx#"one 13") + (try two/no-protect three/normal #rx#"two 10") + (try two/protect three/nabbed (if fail-prot? #rx#"unexported .* unexp" #rx#"one 5")) + (try two/protect three/pnabbed (if fail-pnab? #rx#"protected .* prot" #rx#"zero 8")) + (try two/protect three/snabbed (if (and fail-prot? np-ok?) #rx#"unexported .* stx" #rx#"one 13")) + (try two/protect three/normal (if fail-prot? #rx#"protected .* normal" #rx#"two 10")))) + +;; - - - - - - - - - - - - - - - - - - - - + +(define-values (zero-zo one-zo two/no-protect-zo two/protect-zo + three/nabbed-zo three/pnabbed-zo three/snabbed-zo three/normal-zo) + (apply + values + (let ([ns (make-base-namespace)]) + (parameterize ([current-namespace ns]) + (map (lambda (c) + (let ([c (compile c)] + [p (open-output-bytes)]) + (write c p) + (eval c) + (get-output-bytes p))) + (list zero one two/no-protect two/protect three/nabbed three/pnabbed three/snabbed three/normal)))))) + +;; - - - - - - - - - - - - - - - - - - - - + + +(mp-try-all zero one two/no-protect two/protect three/nabbed three/pnabbed three/snabbed three/normal + current-code-inspector current-code-inspector #f #f #f #f) + +(mp-try-all zero-zo one-zo two/no-protect-zo two/protect-zo three/nabbed-zo three/pnabbed-zo three/snabbed-zo three/normal-zo + current-code-inspector current-code-inspector #f #f #f #f) + +(mp-try-all zero-zo one-zo two/no-protect-zo two/protect-zo three/nabbed-zo three/pnabbed-zo three/snabbed-zo three/normal-zo + make-inspector current-code-inspector #t #f #f #f) + +(mp-try-all zero one two/no-protect two/protect three/nabbed three/pnabbed three/snabbed-zo three/normal + make-inspector current-code-inspector #t #f #t #f) + +(mp-try-all zero-zo one-zo two/no-protect-zo two/protect-zo three/nabbed-zo three/pnabbed-zo three/snabbed-zo three/normal-zo + current-code-inspector make-inspector #t #t #f #f) + +(mp-try-all zero one two/no-protect two/protect three/nabbed three/pnabbed three/snabbed three/normal + current-code-inspector make-inspector #t #t #t #t) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(report-errs) diff --git a/collects/tests/mzscheme/mz-tests.ss b/collects/tests/mzscheme/mz-tests.ss index dfc0d5921f..07e8f7adc7 100644 --- a/collects/tests/mzscheme/mz-tests.ss +++ b/collects/tests/mzscheme/mz-tests.ss @@ -23,6 +23,7 @@ (load-relative "prompt.ss") (load-relative "will.ss") (load-relative "namespac.ss") +(load-relative "modprot.ss") (unless (or building-flat-tests? in-drscheme?) (load-relative "param.ss")) (load-relative "port.ss") diff --git a/collects/tests/r6rs/syntax-case.sls b/collects/tests/r6rs/syntax-case.sls index 696a2e98f3..a06279347d 100644 --- a/collects/tests/r6rs/syntax-case.sls +++ b/collects/tests/r6rs/syntax-case.sls @@ -216,7 +216,7 @@ (test (bound-identifier=? #'cons #'kons) #f) (test (free-identifier=? #'x #'x) #t) (test (free-identifier=? #'x #'y) #f) - (test (free-identifier=? #'cons #'kons) #t) + ;; (test (free-identifier=? #'cons #'kons) #t) ;; see PLT bug report #10210 (test (syntax->datum #'1) 1) (test (syntax->datum #'a) 'a) diff --git a/collects/tests/run-automated-tests.ss b/collects/tests/run-automated-tests.ss index e72674ddd0..e9c8ce1f69 100755 --- a/collects/tests/run-automated-tests.ss +++ b/collects/tests/run-automated-tests.ss @@ -33,7 +33,7 @@ (define tests '([no-handler load "mzscheme/quiet.ss" (lib "scheme/init")] ;; [require "planet/lang.ss"] - [require "typed-scheme/run.ss"] + ;; [require "typed-scheme/run.ss"] [require "match/plt-match-tests.ss"] ;; [require "stepper/automatic-tests.ss" (lib "scheme/base")] [require "lazy/main.ss"] diff --git a/collects/tests/typed-scheme/succeed/for-lists.ss b/collects/tests/typed-scheme/succeed/for-lists.ss new file mode 100644 index 0000000000..2cd0205886 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/for-lists.ss @@ -0,0 +1,6 @@ +#lang typed-scheme + +(: f ((Listof Number) -> (Listof Number))) +(define (f x) + (for/lists (#{y : (Listof Number)}) ([e (in-list x)]) + e)) diff --git a/collects/tests/typed-scheme/succeed/match-tests.ss b/collects/tests/typed-scheme/succeed/match-tests.ss new file mode 100644 index 0000000000..3686d07c2f --- /dev/null +++ b/collects/tests/typed-scheme/succeed/match-tests.ss @@ -0,0 +1,9 @@ +#lang typed-scheme + +(require scheme/match) + +(match "abc" + [(regexp "^abc") 1]) + +(match (list 1 1) + [(list x x) 1]) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss index ee5a483b99..ff39c7f171 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss @@ -87,7 +87,7 @@ (+ 1 (car x)) 5)) N] - + (tc-e (if (let ([y 12]) y) 3 4) -Integer) (tc-e 3 -Integer) (tc-e "foo" -String) (tc-e (+ 3 4) -Integer) @@ -496,10 +496,10 @@ [tc-e (raise-type-error 'foo "bar" 7 (list 5)) (Un)] #;[tc-e - (let ((x '(1 3 5 7 9))) - (do: : Number ((x : (list-of Number) x (cdr x)) - (sum : Number 0 (+ sum (car x)))) - ((null? x) sum))) + (let ((x '(1 3 5 7 9))) + (do: : Number ((x : (list-of Number) x (cdr x)) + (sum : Number 0 (+ sum (car x)))) + ((null? x) sum))) N] @@ -541,10 +541,10 @@ [tc-e `(4 ,@'(3)) (-pair N (-lst N))] [tc-e - (let ((x '(1 3 5 7 9))) - (do: : Number ((x : (Listof Number) x (cdr x)) - (sum : Number 0 (+ sum (car x)))) - ((null? x) sum))) + (let ((x '(1 3 5 7 9))) + (do: : Number ((x : (Listof Number) x (cdr x)) + (sum : Number 0 (+ sum (car x)))) + ((null? x) sum))) N] [tc-e (if #f 1 'foo) (-val 'foo)] diff --git a/collects/web-server/scribblings/servlet-env.scrbl b/collects/web-server/scribblings/servlet-env.scrbl index 3186e86075..ca3e325f24 100644 --- a/collects/web-server/scribblings/servlet-env.scrbl +++ b/collects/web-server/scribblings/servlet-env.scrbl @@ -120,7 +120,7 @@ and if @scheme[serve/servlet] is run in another module. (regexp-quote servlet-path)))] [#:stateless? stateless? boolean? #f] [#:stuffer stuffer (stuffer/c serializable? bytes?) default-stuffer] - [#:manager manager manager? (make-threshold-LRU-manager #f (* 1024 1024 64))] + [#:manager manager manager? (make-threshold-LRU-manager #f (* 128 1024 1024))] [#:servlet-namespace servlet-namespace (listof module-path?) empty] [#:server-root-path server-root-path path-string? default-server-root-path] [#:extra-files-paths extra-files-paths (listof path-string?) (list (build-path server-root-path "htdocs"))] diff --git a/collects/web-server/servlet-env.ss b/collects/web-server/servlet-env.ss index c2696af973..084bbd2301 100644 --- a/collects/web-server/servlet-env.ss +++ b/collects/web-server/servlet-env.ss @@ -94,7 +94,7 @@ (lambda (request) `(html (head (title "Page Has Expired.")) (body (p "Sorry, this page has expired. Please go back.")))) - (* 64 1024 1024))] + (* 128 1024 1024))] #:servlet-path [servlet-path "/servlets/standalone.ss"] diff --git a/src/mred/mred.cxx b/src/mred/mred.cxx index cc6d86f247..b975326b7b 100644 --- a/src/mred/mred.cxx +++ b/src/mred/mred.cxx @@ -1743,7 +1743,7 @@ static void MrEdSleep(float secs, void *fds) } #ifdef wx_msw - MrEdMSWSleep(secs, fds); + MrEdMSWSleep(secs, fds, mzsleep); #else # ifdef wx_mac MrEdMacSleep(secs, fds, mzsleep); @@ -2214,6 +2214,44 @@ static Scheme_Object *stdin_pipe; #if WCONSOLE_STDIO static HANDLE console_out; +static HANDLE console_in; +static Scheme_Object *console_inport; +static HWND console_hwnd; +static int has_stdio, stdio_kills_prog; +static HANDLE waiting_sema; + +typedef HWND (WINAPI* gcw_proc)(); + +static BOOL WINAPI ConsoleHandler(DWORD op) +{ + if (stdio_kills_prog) { + ReleaseSemaphore(waiting_sema, 1, NULL); + } else { + scheme_break_main_thread(); + scheme_signal_received(); + } + return TRUE; +} + +static void WaitOnConsole() +{ + DWORD wrote; + + stdio_kills_prog = 1; + if (console_hwnd) { + AppendMenu(GetSystemMenu(console_hwnd, FALSE), + MF_STRING, + SC_CLOSE, + "Close"); + /* Un-gray the close box: */ + RedrawWindow(console_hwnd, NULL, NULL, + RDW_FRAME | RDW_INVALIDATE | RDW_UPDATENOW); + } + + WriteConsole(console_out, "\n[Exited. Close box or Ctrl-C closes the console.]\n", 51, &wrote, NULL); + + WaitForSingleObject(waiting_sema, INFINITE); +} #else /* !WCONSOLE_STDIO */ @@ -2238,6 +2276,33 @@ static void MrEdSchemeMessages(char *msg, ...) if (!console_out) { AllocConsole(); console_out = GetStdHandle(STD_OUTPUT_HANDLE); + console_in = GetStdHandle(STD_INPUT_HANDLE); + has_stdio = 1; + waiting_sema = CreateSemaphore(NULL, 0, 1, NULL); + SetConsoleCtrlHandler(ConsoleHandler, TRUE); + + wxREGGLOB(console_inport); + console_inport = scheme_make_fd_input_port((int)console_in, scheme_intern_symbol("stdin"), 0, 0); + + { + HMODULE hm; + gcw_proc gcw; + + hm = LoadLibrary("kernel32.dll"); + if (hm) + gcw = (gcw_proc)GetProcAddress(hm, "GetConsoleWindow"); + else + gcw = NULL; + + if (gcw) + console_hwnd = gcw(); + } + + if (console_hwnd) { + EnableMenuItem(GetSystemMenu(console_hwnd, FALSE), SC_CLOSE, + MF_BYCOMMAND | MF_GRAYED); + RemoveMenu(GetSystemMenu(console_hwnd, FALSE), SC_CLOSE, MF_BYCOMMAND); + } } #endif #if REDIRECT_STDIO @@ -2253,18 +2318,21 @@ static void MrEdSchemeMessages(char *msg, ...) #if WCONSOLE_STDIO if (!msg) { char *s; - long l; - DWORD wrote; + long l, d; + DWORD wrote; s = va_arg(args, char*); + d = va_arg(args, long); l = va_arg(args, long); - WriteConsole(console_out, s, l, &wrote, NULL); + WriteConsole(console_out, s XFORM_OK_PLUS d, l, &wrote, NULL); } else { - char buffer[2048]; + char *buffer; DWORD wrote; + buffer = (char *)malloc(5 * strlen(msg)); vsprintf(buffer, msg, args); WriteConsole(console_out, buffer, strlen(buffer), &wrote, NULL); + free(buffer); } #endif #if !WCONSOLE_STDIO @@ -2345,22 +2413,64 @@ static long mrconsole_get_string(Scheme_Input_Port *ip, Scheme_Object *pipe = (Scheme_Object *)ip->port_data; MrEdSchemeMessages(""); +#if WCONSOLE_STDIO + pipe = console_inport; +#endif + add_console_reading(); - result = scheme_get_byte_string("console get-string", pipe, buffer, offset, size, nonblock ? 2 : 0, 0, 0); + result = scheme_get_byte_string_unless("console get-string", pipe, + buffer, offset, size, + nonblock, 0, NULL, + unless); remove_console_reading(); return result; } +static Scheme_Object *mrconsole_progress_evt(Scheme_Input_Port *ip) +{ + Scheme_Object *pipe = (Scheme_Object *)ip->port_data; + MrEdSchemeMessages(""); + +#if WCONSOLE_STDIO + pipe = console_inport; +#endif + + return scheme_progress_evt(pipe); +} + +static int mrconsole_peeked_read(Scheme_Input_Port *ip, + long amount, + Scheme_Object *unless, + Scheme_Object *target_ch) +{ + Scheme_Object *pipe = (Scheme_Object *)ip->port_data; + MrEdSchemeMessages(""); + +#if WCONSOLE_STDIO + pipe = console_inport; +#endif + + return scheme_peeked_read(pipe, amount, unless, target_ch); +} + static int mrconsole_char_ready(Scheme_Input_Port *ip) { Scheme_Object *pipe = (Scheme_Object *)ip->port_data; MrEdSchemeMessages(""); + +#if WCONSOLE_STDIO + pipe = console_inport; +#endif + return scheme_char_ready(pipe); } static void mrconsole_close(Scheme_Input_Port *ip) { Scheme_Object *pipe = (Scheme_Object *)ip->port_data; +#if WCONSOLE_STDIO + pipe = console_inport; +#endif scheme_close_input_port(pipe); } @@ -2378,8 +2488,8 @@ static Scheme_Object *MrEdMakeStdIn(void) scheme_intern_symbol("mred-console"), CAST_GS mrconsole_get_string, NULL, - scheme_progress_evt_via_get, - scheme_peeked_read_via_get, + mrconsole_progress_evt, + mrconsole_peeked_read, CAST_IREADY mrconsole_char_ready, CAST_ICLOSE mrconsole_close, NULL, @@ -2898,6 +3008,20 @@ static Scheme_Env *setup_basic_env() return global_env; } +#if WCONSOLE_STDIO +static void MrEdExit(int v) +{ + if (has_stdio) { + WaitOnConsole(); + } + +#ifdef wx_msw + mred_clean_up_gdi_objects(); +#endif + scheme_immediate_exit(v); +} +#endif + wxFrame *MrEdApp::OnInit(void) { MrEdContext *mmc; @@ -3027,6 +3151,15 @@ wxFrame *MrEdApp::OnInit(void) mred_run_from_cmd_line(argc, argv, setup_basic_env); +#if WCONSOLE_STDIO + if (!wx_in_terminal) { + /* The only reason we get here is that a command-line error or + -h occured. In either case, stick around for the sake of the + console. */ + MrEdExit(1); + } +#endif + return NULL; } @@ -3052,6 +3185,10 @@ void MrEdApp::RealInit(void) initialized = 1; thread->on_kill = CAST_TOK on_main_killed; +#if WCONSOLE_STDIO + if (!wx_in_terminal) + scheme_exit = CAST_EXIT MrEdExit; +#endif #ifdef wx_xt if (wx_single_instance) { diff --git a/src/mred/mred.h b/src/mred/mred.h index cbd35c0aea..48c6053a97 100644 --- a/src/mred/mred.h +++ b/src/mred/mred.h @@ -110,7 +110,7 @@ extern "C" { } #ifdef wx_msw -void MrEdMSWSleep(float secs, void *fds); +void MrEdMSWSleep(float secs, void *fds, SLEEP_PROC_PTR mzsleep); MRED_EXTERN void mred_clean_up_gdi_objects(void); #endif diff --git a/src/mred/mredmsw.cxx b/src/mred/mredmsw.cxx index bc100a3ced..a6e3ccb121 100644 --- a/src/mred/mredmsw.cxx +++ b/src/mred/mredmsw.cxx @@ -845,7 +845,7 @@ int MrEdCheckForBreak(void) } } -void MrEdMSWSleep(float secs, void *fds) +void MrEdMSWSleep(float secs, void *fds, SLEEP_PROC_PTR mzsleep) { DWORD msecs; @@ -909,30 +909,8 @@ void MrEdMSWSleep(float secs, void *fds) } if (fds) { - win_extended_fd_set *r; - int num_handles, num_rhandles, *rps, result; - HANDLE *handles; - - scheme_collapse_win_fd(fds); /* merges */ - - r = (win_extended_fd_set *)fds; - - num_rhandles = SCHEME_INT_VAL(((win_extended_fd_set *)fds)->num_handles); - num_handles = SCHEME_INT_VAL(((win_extended_fd_set *)fds)->combined_len); - handles = ((win_extended_fd_set *)fds)->combined_wait_array; - rps = ((win_extended_fd_set *)fds)->repost_sema; - - result = MsgWaitForMultipleObjects(num_handles, handles, FALSE, - secs ? msecs : INFINITE, - QS_ALLINPUT); - - if ((result >= WAIT_OBJECT_0) && (result < WAIT_OBJECT_0 + num_rhandles)) { - result -= WAIT_OBJECT_0; - if (rps[result]) - ReleaseSemaphore(handles[result], 1, NULL); - } - - scheme_collapse_win_fd(fds); /* cleans up */ + scheme_add_fd_eventmask(fds, QS_ALLINPUT); + mzsleep(secs, fds); } else if (wxTheApp->keep_going) { MsgWaitForMultipleObjects(0, NULL, FALSE, secs ? msecs : INFINITE, diff --git a/src/mzscheme/gc2/Makefile.in b/src/mzscheme/gc2/Makefile.in index bdbf6a0a35..7208a49765 100644 --- a/src/mzscheme/gc2/Makefile.in +++ b/src/mzscheme/gc2/Makefile.in @@ -132,7 +132,7 @@ xsrc: xobjects: $(OBJS) main.@LTO@ -XFORMDEP = $(srcdir)/gc2.h $(srcdir)/xform.ss $(srcdir)/xform-mod.ss \ +XFORMDEP = $(srcdir)/gc2.h $(srcdir)/gc2_obj.h $(srcdir)/xform.ss $(srcdir)/xform-mod.ss \ $(srcdir)/precomp.c $(srcdir)/../src/schpriv.h $(srcdir)/../include/scheme.h \ $(srcdir)/../sconfig.h $(srcdir)/../uconfig.h $(srcdir)/../src/schemef.h \ $(srcdir)/../src/stypes.h diff --git a/src/mzscheme/gc2/mem_account.c b/src/mzscheme/gc2/mem_account.c index c9e9ba92e2..32d168f2d6 100644 --- a/src/mzscheme/gc2/mem_account.c +++ b/src/mzscheme/gc2/mem_account.c @@ -239,13 +239,26 @@ inline static unsigned long custodian_usage(NewGC*gc, void *custodian) inline static void BTC_memory_account_mark(NewGC *gc, mpage *page, void *ptr) { GCDEBUG((DEBUGOUTF, "BTC_memory_account_mark: %p/%p\n", page, ptr)); - if(page->big_page) { - struct objhead *info = (struct objhead *)(NUM(page->addr) + PREFIX_SIZE); + if(page->size_class) { + if(page->size_class > 1) { + /* big page */ + struct objhead *info = (struct objhead *)(NUM(page->addr) + PREFIX_SIZE); + + if(info->btc_mark == gc->old_btc_mark) { + info->btc_mark = gc->new_btc_mark; + account_memory(gc, gc->current_mark_owner, gcBYTES_TO_WORDS(page->size)); + push_ptr(ptr); + } + } else { + /* medium page */ + struct objhead *info = MED_OBJHEAD(ptr, page->size); - if(info->btc_mark == gc->old_btc_mark) { - info->btc_mark = gc->new_btc_mark; - account_memory(gc, gc->current_mark_owner, gcBYTES_TO_WORDS(page->size)); - push_ptr(ptr); + if(info->btc_mark == gc->old_btc_mark) { + info->btc_mark = gc->new_btc_mark; + account_memory(gc, gc->current_mark_owner, info->size); + ptr = PTR(NUM(info) + WORD_SIZE); + push_ptr(ptr); + } } } else { struct objhead *info = (struct objhead *)((char*)ptr - WORD_SIZE); @@ -315,9 +328,9 @@ int BTC_cust_box_mark(void *p) return gc->mark_table[btc_redirect_cust_box](p); } -inline static void mark_normal_obj(NewGC *gc, mpage *page, void *ptr) +inline static void mark_normal_obj(NewGC *gc, int type, void *ptr) { - switch(page->page_type) { + switch(type) { case PAGE_TAGGED: { /* we do not want to mark the pointers in a thread or custodian unless the object's owner is the current owner. In the case @@ -374,7 +387,6 @@ inline static void mark_acc_big_page(NewGC *gc, mpage *page) } } - static void btc_overmem_abort(NewGC *gc) { gc->kill_propagation_loop = 1; @@ -391,10 +403,16 @@ static void propagate_accounting_marks(NewGC *gc) page = pagemap_find_page(pagemap, p); set_backtrace_source(p, page->page_type); GCDEBUG((DEBUGOUTF, "btc_account: popped off page %p:%p, ptr %p\n", page, page->addr, p)); - if(page->big_page) - mark_acc_big_page(gc, page); - else - mark_normal_obj(gc, page, p); + if(page->size_class) { + if (page->size_class > 1) + mark_acc_big_page(gc, page); + else { + struct objhead *info = MED_OBJHEAD(p, page->size); + p = PTR(NUM(info) + WORD_SIZE); + mark_normal_obj(gc, info->type, p); + } + } else + mark_normal_obj(gc, page->page_type, p); } if(gc->kill_propagation_loop) reset_pointer_stack(); diff --git a/src/mzscheme/gc2/newgc.c b/src/mzscheme/gc2/newgc.c index 5462977929..129c030cad 100644 --- a/src/mzscheme/gc2/newgc.c +++ b/src/mzscheme/gc2/newgc.c @@ -91,7 +91,6 @@ inline static int is_master_gc(NewGC *gc) { return (MASTERGC == gc); } - #include "msgprint.c" /*****************************************************************************/ @@ -364,7 +363,7 @@ inline static void pagemap_modify_with_size(PageMap pagemap, mpage *page, long s } inline static void pagemap_modify(PageMap pagemap, mpage *page, mpage *val) { - long size = page->big_page ? page->size : APAGE_SIZE; + long size = (page->size_class > 1) ? page->size : APAGE_SIZE; pagemap_modify_with_size(pagemap, page, size, val); } @@ -420,6 +419,8 @@ int GC_is_allocated(void *p) #endif #define PREFIX_SIZE (PREFIX_WSIZE * WORD_SIZE) +#define MED_OBJHEAD(p, bytesize) ((struct objhead *)(PTR(((((NUM(p) & (APAGE_SIZE - 1)) - PREFIX_SIZE) / bytesize) * bytesize) \ + + (NUM(p) & (~(APAGE_SIZE - 1))) + PREFIX_SIZE))) /* this is the maximum size of an object that will fit on a page, in words. the "- 3" is basically used as a fudge/safety factor, and has no real, @@ -437,7 +438,7 @@ int GC_is_allocated(void *p) gc->gen0.curr_alloc_page is the member of this list we are currently allocating on. The size count helps us trigger collection quickly when we're running out of space; see the test in allocate_big. - */ +*/ THREAD_LOCAL unsigned long GC_gen0_alloc_page_ptr = 0; THREAD_LOCAL unsigned long GC_gen0_alloc_page_end = 0; @@ -511,7 +512,7 @@ static void *allocate_big(size_t sizeb, int type) addr = malloc_pages(gc, round_to_apage_size(sizeb), APAGE_SIZE); bpage->addr = addr; bpage->size = sizeb; - bpage->big_page = 1; + bpage->size_class = 2; bpage->page_type = type; /* push new bpage onto GC->gen0.big_pages */ @@ -554,12 +555,86 @@ static void *allocate_big(size_t sizeb, int type) # endif #endif +static void *allocate_medium(size_t sizeb, int type) +{ + NewGC *gc; + int sz = 8, pos = 0, n; + void *addr, *p; + struct mpage *page; + struct objhead *info; + + if (sizeb > (1 << (LOG_APAGE_SIZE - 1))) + return allocate_big(sizeb, type); + + while (sz < sizeb) { + sz <<= 1; + pos++; + } + + sz += WORD_SIZE; /* add trailing word, in case pointer is to end */ + sz += WORD_SIZE; /* room for objhead */ + sz = ALIGN_BYTES_SIZE(sz); + + gc = GC_get_GC(); + while (1) { + page = gc->med_freelist_pages[pos]; + if (page) { + n = page->previous_size; + while (n <= (APAGE_SIZE - sz)) { + info = (struct objhead *)PTR(NUM(page->addr) + n); + if (info->dead) { + info->dead = 0; + info->type = type; + page->previous_size = (n + sz); + page->live_size += sz; + p = PTR(NUM(info) + WORD_SIZE); + memset(p, 0, sz - WORD_SIZE); + return p; + } + n += sz; + } + gc->med_freelist_pages[pos] = page->prev; + } else + break; + } + + page = malloc_mpage(); + addr = malloc_pages(gc, APAGE_SIZE, APAGE_SIZE); + page->addr = addr; + page->size = sz; + page->size_class = 1; + page->page_type = PAGE_BIG; + page->previous_size = PREFIX_SIZE; + page->live_size = sz; + + for (n = page->previous_size; (n + sz) <= APAGE_SIZE; n += sz) { + info = (struct objhead *)PTR(NUM(page->addr) + n); + info->dead = 1; + info->size = gcBYTES_TO_WORDS(sz); + } + + page->next = gc->med_pages[pos]; + if (page->next) + page->next->prev = page; + gc->med_pages[pos] = page; + gc->med_freelist_pages[pos] = page; + + pagemap_add(gc->page_maps, page); + + n = page->previous_size; + info = (struct objhead *)PTR(NUM(page->addr) + n); + info->dead = 0; + info->type = type; + + return PTR(NUM(info) + WORD_SIZE); +} + inline static struct mpage *gen0_create_new_mpage(NewGC *gc) { mpage *newmpage; newmpage = malloc_mpage(gc); newmpage->addr = malloc_dirty_pages(gc, GEN0_PAGE_SIZE, APAGE_SIZE); - newmpage->big_page = 0; + newmpage->size_class = 0; newmpage->size = PREFIX_SIZE; pagemap_add_with_size(gc->page_maps, newmpage, GEN0_PAGE_SIZE); @@ -721,9 +796,9 @@ void *GC_malloc_one_xtagged(size_t s) { return allocate(s, PAGE_XTAG void *GC_malloc_array_tagged(size_t s) { return allocate(s, PAGE_TARRAY); } void *GC_malloc_atomic(size_t s) { return allocate(s, PAGE_ATOMIC); } void *GC_malloc_atomic_uncollectable(size_t s) { void *p = ofm_malloc_zero(s); return p; } -void *GC_malloc_allow_interior(size_t s) { return allocate_big(s, PAGE_ARRAY); } +void *GC_malloc_allow_interior(size_t s) { return allocate_medium(s, PAGE_ARRAY); } void *GC_malloc_atomic_allow_interior(size_t s) { return allocate_big(s, PAGE_ATOMIC); } -void *GC_malloc_tagged_allow_interior(size_t s) { return allocate_big(s, PAGE_TAGGED); } +void *GC_malloc_tagged_allow_interior(size_t s) { return allocate_medium(s, PAGE_TAGGED); } void *GC_malloc_one_small_dirty_tagged(size_t s) { return fast_malloc_one_small_tagged(s, 1); } void *GC_malloc_one_small_tagged(size_t s) { return fast_malloc_one_small_tagged(s, 0); } void GC_free(void *p) {} @@ -822,14 +897,21 @@ inline static void reset_nursery(NewGC *gc) false if it isn't. This function assumes that you're talking, at this point, purely about the mark field of the object. It ignores things like the object not being one of our GC heap objects, being in a higher gen - than we're collectiong, not being a pointer at all, etc. */ + than we're collecting, not being a pointer at all, etc. */ inline static int marked(NewGC *gc, void *p) { struct mpage *page; if(!p) return 0; if(!(page = pagemap_find_page(gc->page_maps, p))) return 1; - if((NUM(page->addr) + page->previous_size) > NUM(p)) return 1; + if (page->size_class) { + if (page->size_class > 1) { + return (page->size_class > 2); + } + } else { + if((NUM(page->addr) + page->previous_size) > NUM(p)) + return 1; + } return ((struct objhead *)(NUM(p) - WORD_SIZE))->mark; } @@ -843,11 +925,11 @@ static int collections = 0; static void init_debug_file(void) { /* - char filename_buf[20]; - snprintf(filename_buf, 20, "gclog%d%d", (collections / 10), (collections % 10)); - dump = fopen(filename_buf, "a"); - collections += 1; - */ + char filename_buf[20]; + snprintf(filename_buf, 20, "gclog%d%d", (collections / 10), (collections % 10)); + dump = fopen(filename_buf, "a"); + collections += 1; + */ char *filename = ofm_malloc(8 * sizeof(char)); @@ -870,9 +952,9 @@ static void dump_region(void **start, void **end) { while(start < end) { fprintf(dump, "%.8lx: %.8lx %.8lx %.8lx %.8lx %.8lx %.8lx %.8lx %.8lx\n", - NUM(start), NUM(*start), NUM(*(start + 1)), NUM(*(start + 2)), - NUM(*(start + 3)), NUM(*(start + 4)), NUM(*(start + 5)), - NUM(*(start + 6)), NUM(*(start + 7))); + NUM(start), NUM(*start), NUM(*(start + 1)), NUM(*(start + 2)), + NUM(*(start + 3)), NUM(*(start + 4)), NUM(*(start + 5)), + NUM(*(start + 6)), NUM(*(start + 7))); start += 8; } fprintf(dump, "\n\n"); @@ -886,20 +968,20 @@ static void dump_heap(NewGC *gc) if(collections >= 0) { for(page = gc->gen0.pages; page; page = page->next) { fprintf(dump, "Generation 0 Page (%p:%p - %p, size %i):\n", - page, page->addr, PTR(NUM(page->addr) + GEN0_PAGE_SIZE), page->size); + page, page->addr, PTR(NUM(page->addr) + GEN0_PAGE_SIZE), page->size); dump_region(PPTR(NUM(page->addr) + PREFIX_SIZE), PPTR(NUM(page->addr) + page->size)); } for(page = gc->gen0.big_pages; page; page = page->next) { fprintf(dump, "Page %p:%p (gen %i, type %i, big %i, back %i, size %i)\n", - page, page->addr, page->generation, page->page_type, page->big_page, - page->back_pointers, page->size); + page, page->addr, page->generation, page->page_type, page->big_page, + page->back_pointers, page->size); dump_region(PPTR(NUM(page->addr) + PREFIX_SIZE), PPTR(NUM(page->addr) + page->size)); } for(i = 0; i < PAGE_TYPES; i++) for(page = gc->gen1_pages[i]; page; page = page->next) { fprintf(dump, "Page %p:%p (gen %i, type %i, big %i, back %i, size %i)\n", - page, page->addr, page->generation, page->page_type, page->big_page, - page->back_pointers, page->size); + page, page->addr, page->generation, page->page_type, page->big_page, + page->back_pointers, page->size); dump_region(PPTR(NUM(page->addr) + PREFIX_SIZE), PPTR(NUM(page->addr) + page->size)); } fprintf(dump, "STACK:\n"); @@ -938,9 +1020,12 @@ static void backtrace_new_page(NewGC *gc, mpage *page) page->backtrace = (void **)malloc_pages(gc, APAGE_SIZE, APAGE_SIZE); } +# define backtrace_new_page_if_needed(gc, page) if (!page->backtrace) backtrace_new_page(gc, page) + static void free_backtrace(struct mpage *page) { - free_pages(GC, page->backtrace, APAGE_SIZE); + if (page->backtrace) + free_pages(GC, page->backtrace, APAGE_SIZE); } static void *bt_source; @@ -953,7 +1038,7 @@ static void set_backtrace_source(void *source, int type) } static void record_backtrace(struct mpage *page, void *ptr) - /* ptr is after objhead */ +/* ptr is after objhead */ { unsigned long delta; @@ -963,7 +1048,7 @@ static void record_backtrace(struct mpage *page, void *ptr) } static void copy_backtrace_source(struct mpage *to_page, void *to_ptr, - struct mpage *from_page, void *from_ptr) + struct mpage *from_page, void *from_ptr) /* ptrs are at objhead */ { unsigned long to_delta, from_delta; @@ -976,12 +1061,16 @@ static void copy_backtrace_source(struct mpage *to_page, void *to_ptr, } static void *get_backtrace(struct mpage *page, void *ptr) - /* ptr is after objhead */ +/* ptr is after objhead */ { unsigned long delta; - if (page->big_page) - ptr = PTR((char *)page->addr + PREFIX_SIZE + WORD_SIZE); + if (page->size_class) { + if (page->size_class > 1) + ptr = PTR((char *)page->addr + PREFIX_SIZE + WORD_SIZE); + else + ptr = (char *)MED_OBJHEAD(ptr, page->size) + WORD_SIZE; + } delta = PPTR(ptr) - PPTR(page->addr); return page->backtrace[delta - 1]; @@ -996,6 +1085,7 @@ static void *get_backtrace(struct mpage *page, void *ptr) #else # define backtrace_new_page(gc, page) /* */ +# define backtrace_new_page_if_needed(gc, page) /* */ # define free_backtrace(page) /* */ # define set_backtrace_source(ptr, type) /* */ # define record_backtrace(page, ptr) /* */ @@ -1068,21 +1158,21 @@ static inline void *get_stack_base(NewGC *gc) { #include "roots.c" -#define traverse_roots(gcMUCK, set_bt_src) { \ - unsigned long j; \ - Roots *roots = &gc->roots; \ - if(roots->roots) { \ - sort_and_merge_roots(roots); \ - for(j = 0; j < roots->count; j += 2) { \ - void **start = (void**)roots->roots[j]; \ - void **end = (void**)roots->roots[j+1]; \ - while(start < end) { \ - set_bt_src(start, BT_ROOT); \ - gcMUCK(*start++); \ - } \ - } \ - } \ -} +#define traverse_roots(gcMUCK, set_bt_src) { \ + unsigned long j; \ + Roots *roots = &gc->roots; \ + if(roots->roots) { \ + sort_and_merge_roots(roots); \ + for(j = 0; j < roots->count; j += 2) { \ + void **start = (void**)roots->roots[j]; \ + void **end = (void**)roots->roots[j+1]; \ + while(start < end) { \ + set_bt_src(start, BT_ROOT); \ + gcMUCK(*start++); \ + } \ + } \ + } \ + } inline static void mark_roots(NewGC *gc) { @@ -1156,8 +1246,8 @@ inline static void check_finalizers(NewGC *gc, int level) struct finalizer *next = GC_resolve(work->next); GCDEBUG((DEBUGOUTF, - "CFNL: Level %i finalizer %p on %p queued for finalization.\n", - work->eager_level, work, work->p)); + "CFNL: Level %i finalizer %p on %p queued for finalization.\n", + work->eager_level, work, work->p)); set_backtrace_source(work, BT_FINALIZER); gcMARK(work->p); if(prev) prev->next = next; @@ -1170,8 +1260,8 @@ inline static void check_finalizers(NewGC *gc, int level) work = next; } else { GCDEBUG((DEBUGOUTF, "CFNL: Not finalizing %p (level %i on %p): %p / %i\n", - work, work->eager_level, work->p, pagemap_find_page(gc->page_maps, work->p), - marked(work->p))); + work, work->eager_level, work->p, pagemap_find_page(gc->page_maps, work->p), + marked(work->p))); prev = work; work = GC_resolve(work->next); } @@ -1186,8 +1276,8 @@ inline static void do_ordered_level3(NewGC *gc) for(temp = GC_resolve(gc->finalizers); temp; temp = GC_resolve(temp->next)) if(!marked(gc, temp->p)) { GCDEBUG((DEBUGOUTF, - "LVL3: %p is not marked. Marking payload (%p)\n", - temp, temp->p)); + "LVL3: %p is not marked. Marking payload (%p)\n", + temp, temp->p)); set_backtrace_source(temp, BT_FINALIZER); if(temp->tagged) mark_table[*(unsigned short*)temp->p](temp->p); if(!temp->tagged) GC_mark_xtagged(temp->p); @@ -1432,7 +1522,7 @@ static int designate_modified_gc(NewGC *gc, void *p) if(page) { if (!page->back_pointers) { page->mprotected = 0; - vm_protect_pages(page->addr, page->big_page ? round_to_apage_size(page->size) : APAGE_SIZE, 1); + vm_protect_pages(page->addr, (page->size_class > 1) ? round_to_apage_size(page->size) : APAGE_SIZE, 1); page->back_pointers = 1; return 1; } @@ -1545,9 +1635,9 @@ void GC_init_type_tags(int count, int pair, int mutable_pair, int weakbox, int e } void GC_construct_child_gc() { - NewGC *gc = MASTERGC; - NewGC *newgc = init_type_tags_worker(gc, 0, 0, 0, gc->weak_box_tag, gc->ephemeron_tag, gc->weak_array_tag, gc->cust_box_tag); - newgc->primoridal_gc = MASTERGC; + NewGC *gc = MASTERGC; + NewGC *newgc = init_type_tags_worker(gc, 0, 0, 0, gc->weak_box_tag, gc->ephemeron_tag, gc->weak_array_tag, gc->cust_box_tag); + newgc->primoridal_gc = MASTERGC; } static inline void save_globals_to_gc(NewGC *gc) { @@ -1592,7 +1682,7 @@ void GC_gcollect(void) } void GC_register_traversers(short tag, Size_Proc size, Mark_Proc mark, - Fixup_Proc fixup, int constant_Size, int atomic) + Fixup_Proc fixup, int constant_Size, int atomic) { NewGC *gc = GC_get_GC(); @@ -1655,48 +1745,62 @@ void GC_mark(const void *const_p) #endif } - if(page->big_page) { - /* This is a bigpage. The first thing we do is see if its been marked - previously */ - if(page->big_page != 1) { - GCDEBUG((DEBUGOUTF, "Not marking %p on big %p (already marked)\n", p, page)); - return; - } - /* in this case, it has not. So we want to mark it, first off. */ - page->big_page = 2; + if(page->size_class) { + if(page->size_class > 1) { + /* This is a bigpage. The first thing we do is see if its been marked + previously */ + if(page->size_class != 2) { + GCDEBUG((DEBUGOUTF, "Not marking %p on big %p (already marked)\n", p, page)); + return; + } + /* in this case, it has not. So we want to mark it, first off. */ + page->size_class = 3; - /* if this is in the nursery, we want to move it out of the nursery */ - if(!page->generation) { - page->generation = 1; + /* if this is in the nursery, we want to move it out of the nursery */ + if(!page->generation) { + page->generation = 1; - /* remove page */ - if(page->prev) page->prev->next = page->next; else - gc->gen0.big_pages = page->next; - if(page->next) page->next->prev = page->prev; + /* remove page */ + if(page->prev) page->prev->next = page->next; else + gc->gen0.big_pages = page->next; + if(page->next) page->next->prev = page->prev; - backtrace_new_page(gc, page); + backtrace_new_page(gc, page); - /* add to gen1 */ - page->next = gc->gen1_pages[PAGE_BIG]; - page->prev = NULL; - if(page->next) page->next->prev = page; - gc->gen1_pages[PAGE_BIG] = page; + /* add to gen1 */ + page->next = gc->gen1_pages[PAGE_BIG]; + page->prev = NULL; + if(page->next) page->next->prev = page; + gc->gen1_pages[PAGE_BIG] = page; - /* if we're doing memory accounting, then we need to make sure the - btc_mark is right */ + /* if we're doing memory accounting, then we need to make sure the + btc_mark is right */ #ifdef NEWGC_BTC_ACCOUNT - BTC_set_btc_mark(gc, PTR(NUM(page->addr) + PREFIX_SIZE)); + BTC_set_btc_mark(gc, PTR(NUM(page->addr) + PREFIX_SIZE)); #endif - } + } - page->marked_on = 1; - record_backtrace(page, PTR(NUM(page->addr) + PREFIX_SIZE + WORD_SIZE)); - GCDEBUG((DEBUGOUTF, "Marking %p on big page %p\n", p, page)); - /* Finally, we want to add this to our mark queue, so we can - propagate its pointers */ - push_ptr(p); - } - else { + page->marked_on = 1; + record_backtrace(page, PTR(NUM(page->addr) + PREFIX_SIZE + WORD_SIZE)); + GCDEBUG((DEBUGOUTF, "Marking %p on big page %p\n", p, page)); + /* Finally, we want to add this to our mark queue, so we can + propagate its pointers */ + push_ptr(p); + } else { + /* A medium page. */ + struct objhead *info = MED_OBJHEAD(p, page->size); + if (info->mark) { + GCDEBUG((DEBUGOUTF,"Not marking %p (already marked)\n", p)); + return; + } + info->mark = 1; + page->marked_on = 1; + p = PTR(NUM(info) + WORD_SIZE); + backtrace_new_page_if_needed(gc, page); + record_backtrace(page, p); + push_ptr(p); + } + } else { struct objhead *ohead = (struct objhead *)(NUM(p) - WORD_SIZE); if(ohead->mark) { @@ -1721,7 +1825,7 @@ void GC_mark(const void *const_p) record_backtrace(page, p); push_ptr(p); } else GCDEBUG((DEBUGOUTF, "Not marking %p (it's old; %p / %i)\n", - p, page, page->previous_size)); + p, page, page->previous_size)); } else { /* this is a generation 0 object. This means that we do have to do all of the above. Fun, fun, fun. */ @@ -1820,13 +1924,14 @@ static void propagate_marks(NewGC *gc) /* we can assume a lot here -- like it's a valid pointer with a page -- because we vet bad cases out in GC_mark, above */ - if(page->big_page) { - void **start = PPTR(NUM(page->addr) + PREFIX_SIZE + WORD_SIZE); - void **end = PPTR(NUM(page->addr) + page->size); + if(page->size_class) { + if(page->size_class > 1) { + void **start = PPTR(NUM(page->addr) + PREFIX_SIZE + WORD_SIZE); + void **end = PPTR(NUM(page->addr) + page->size); - set_backtrace_source(start, page->page_type); + set_backtrace_source(start, page->page_type); - switch(page->page_type) { + switch(page->page_type) { case PAGE_TAGGED: { unsigned short tag = *(unsigned short*)start; @@ -1840,22 +1945,24 @@ static void propagate_marks(NewGC *gc) case PAGE_ATOMIC: break; case PAGE_ARRAY: while(start < end) gcMARK(*(start++)); break; case PAGE_XTAGGED: GC_mark_xtagged(start); break; - case PAGE_TARRAY: { - unsigned short tag = *(unsigned short *)start; - end -= INSET_WORDS; - while(start < end) { - GC_ASSERT(mark_table[tag]); - start += mark_table[tag](start); - } - break; - } - } - } else { - struct objhead *info = (struct objhead *)(NUM(p) - WORD_SIZE); + case PAGE_TARRAY: + { + unsigned short tag = *(unsigned short *)start; + end -= INSET_WORDS; + while(start < end) { + GC_ASSERT(mark_table[tag]); + start += mark_table[tag](start); + } + break; + } + } + } else { + /* Medium page */ + struct objhead *info = (struct objhead *)(NUM(p) - WORD_SIZE); - set_backtrace_source(p, info->type); + set_backtrace_source(p, info->type); - switch(info->type) { + switch(info->type) { case PAGE_TAGGED: { unsigned short tag = *(unsigned short*)p; @@ -1863,24 +1970,46 @@ static void propagate_marks(NewGC *gc) mark_table[tag](p); break; } - case PAGE_ATOMIC: break; - case PAGE_ARRAY: { - void **start = p; - void **end = PPTR(info) + info->size; - while(start < end) gcMARK(*start++); - break; - } - case PAGE_TARRAY: { - void **start = p; - void **end = PPTR(info) + (info->size - INSET_WORDS); - unsigned short tag = *(unsigned short *)start; - while(start < end) { - GC_ASSERT(mark_table[tag]); - start += mark_table[tag](start); - } - break; - } - case PAGE_XTAGGED: GC_mark_xtagged(p); break; + case PAGE_ARRAY: + { + void **start = p; + void **end = PPTR(info) + info->size; + while(start < end) gcMARK(*start++); + break; + } + } + } + } else { + struct objhead *info = (struct objhead *)(NUM(p) - WORD_SIZE); + + set_backtrace_source(p, info->type); + + switch(info->type) { + case PAGE_TAGGED: + { + unsigned short tag = *(unsigned short*)p; + GC_ASSERT(mark_table[tag]); + mark_table[tag](p); + break; + } + case PAGE_ATOMIC: break; + case PAGE_ARRAY: { + void **start = p; + void **end = PPTR(info) + info->size; + while(start < end) gcMARK(*start++); + break; + } + case PAGE_TARRAY: { + void **start = p; + void **end = PPTR(info) + (info->size - INSET_WORDS); + unsigned short tag = *(unsigned short *)start; + while(start < end) { + GC_ASSERT(mark_table[tag]); + start += mark_table[tag](start); + } + break; + } + case PAGE_XTAGGED: GC_mark_xtagged(p); break; } } } @@ -1892,7 +2021,7 @@ void *GC_resolve(void *p) struct mpage *page = pagemap_find_page(gc->page_maps, p); struct objhead *info; - if(!page || page->big_page) + if(!page || page->size_class) return p; info = (struct objhead *)(NUM(p) - WORD_SIZE); @@ -1920,7 +2049,7 @@ void GC_fixup(void *pp) if((page = pagemap_find_page(gc->page_maps, p))) { struct objhead *info; - if(page->big_page) return; + if(page->size_class) return; info = (struct objhead *)(NUM(p) - WORD_SIZE); if(info->mark && info->moved) *(void**)pp = *(void**)p; @@ -1935,12 +2064,15 @@ void GC_fixup(void *pp) #ifdef MZ_GC_BACKTRACE # define trace_page_t struct mpage # define trace_page_type(page) (page)->page_type - static void *trace_pointer_start(struct mpage *page, void *p) { - if (page->big_page) +static void *trace_pointer_start(struct mpage *page, void *p) { + if (page->size_class) { + if (page->size_class > 1) return PTR(NUM(page->addr) + PREFIX_SIZE + WORD_SIZE); - else - return p; - } + else + return PTR(NUM(MED_OBJHEAD(p, page->size)) + WORD_SIZE); + } else + return p; +} # define TRACE_PAGE_TAGGED PAGE_TAGGED # define TRACE_PAGE_ARRAY PAGE_ARRAY # define TRACE_PAGE_TAGGED_ARRAY PAGE_TARRAY @@ -1948,7 +2080,7 @@ void GC_fixup(void *pp) # define TRACE_PAGE_XTAGGED PAGE_XTAGGED # define TRACE_PAGE_MALLOCFREE PAGE_TYPES # define TRACE_PAGE_BAD PAGE_TYPES -# define trace_page_is_big(page) (page)->big_page +# define trace_page_is_big(page) (page)->size_class # define trace_backpointer get_backtrace # include "backtrace.c" #else @@ -1960,12 +2092,12 @@ void GC_fixup(void *pp) #define MAX_DUMP_TAG 256 void GC_dump_with_traces(int flags, - GC_get_type_name_proc get_type_name, - GC_get_xtagged_name_proc get_xtagged_name, - GC_for_each_found_proc for_each_found, - short trace_for_tag, - GC_print_tagged_value_proc print_tagged_value, - int path_length_limit) + GC_get_type_name_proc get_type_name, + GC_get_xtagged_name_proc get_xtagged_name, + GC_for_each_found_proc for_each_found, + short trace_for_tag, + GC_print_tagged_value_proc print_tagged_value, + int path_length_limit) { NewGC *gc = GC_get_GC(); mpage *page; @@ -2017,6 +2149,31 @@ void GC_dump_with_traces(int flags, } } } + for (i = 0; i < NUM_MED_PAGE_SIZES; i++) { + for (page = gc->med_pages[i]; page; page = page->next) { + void **start = PPTR(NUM(page->addr) + PREFIX_SIZE); + void **end = PPTR(NUM(page->addr) + APAGE_SIZE - page->size); + + while(start <= end) { + struct objhead *info = (struct objhead *)start; + if (!info->dead) { + if (info->type == PAGE_TAGGED) { + unsigned short tag = *(unsigned short *)(start + 1); + if (tag < MAX_DUMP_TAG) { + counts[tag]++; + sizes[tag] += info->size; + } + if (tag == trace_for_tag) { + register_traced_object(start + 1); + if (for_each_found) + for_each_found(start + 1); + } + } + } + start += info->size; + } + } + } GCPRINT(GCOUTF, "Begin MzScheme3m\n"); for (i = 0; i < MAX_DUMP_TAG; i++) { @@ -2045,15 +2202,39 @@ void GC_dump_with_traces(int flags, count++; } GCWARN((GCOUTF, "Generation 1 [%s]: %li bytes used in %li pages\n", - type_name[i], total_use, count)); + type_name[i], total_use, count)); } + GCWARN((GCOUTF, "Generation 1 [medium]:")); + for (i = 0; i < NUM_MED_PAGE_SIZES; i++) { + if (gc->med_pages[i]) { + long count = 0, page_count = 0; + for (page = gc->med_pages[i]; page; page = page->next) { + void **start = PPTR(NUM(page->addr) + PREFIX_SIZE); + void **end = PPTR(NUM(page->addr) + APAGE_SIZE - page->size); + + page_count++; + + while(start <= end) { + struct objhead *info = (struct objhead *)start; + if (!info->dead) { + count += info->size; + } + start += info->size; + } + } + GCWARN((GCOUTF, " %li [%li/%li]", count, page_count, gc->med_pages[i]->size)); + } + } + GCWARN((GCOUTF, "\n")); + + GCWARN((GCOUTF,"\n")); GCWARN((GCOUTF,"Current memory use: %li\n", GC_get_memory_use(NULL))); GCWARN((GCOUTF,"Peak memory use after a collection: %li\n", gc->peak_memory_use)); GCWARN((GCOUTF,"Allocated (+reserved) page sizes: %li (+%li)\n", - gc->used_pages * APAGE_SIZE, - vm_memory_allocated(gc->vm) - (gc->used_pages * APAGE_SIZE))); + gc->used_pages * APAGE_SIZE, + vm_memory_allocated(gc->vm) - (gc->used_pages * APAGE_SIZE))); GCWARN((GCOUTF,"# of major collections: %li\n", gc->num_major_collects)); GCWARN((GCOUTF,"# of minor collections: %li\n", gc->num_minor_collects)); GCWARN((GCOUTF,"# of installed finalizers: %i\n", gc->num_fnls)); @@ -2098,49 +2279,81 @@ void *GC_next_tagged_start(void *p) /* garbage collection */ /*****************************************************************************/ +static void reset_gen1_page(NewGC *gc, mpage *work) +{ + if (gc->generations_available && work->mprotected) { + work->mprotected = 0; + add_protect_page_range(gc->protect_range, work->addr, + (work->size_class > 1) ? round_to_apage_size(work->size) : APAGE_SIZE, + APAGE_SIZE, 1); + } +} + static void reset_gen1_pages_live_and_previous_sizes(NewGC *gc) { - Page_Range *protect_range = gc->protect_range; mpage *work; int i; GCDEBUG((DEBUGOUTF, "MAJOR COLLECTION - PREPPING PAGES - reset live_size, reset previous_size, unprotect.\n")); /* we need to make sure that previous_size for every page is reset, so we don't accidentally screw up the mark routine */ + for(i = 0; i < PAGE_TYPES; i++) { for(work = gc->gen1_pages[i]; work; work = work->next) { - if (gc->generations_available && work->mprotected) { - work->mprotected = 0; - add_protect_page_range(protect_range, work->addr, work->big_page ? round_to_apage_size(work->size) : APAGE_SIZE, APAGE_SIZE, 1); - } + reset_gen1_page(gc, work); work->live_size = 0; work->previous_size = PREFIX_SIZE; } } - flush_protect_page_ranges(protect_range, 1); + + for (i = 0; i < NUM_MED_PAGE_SIZES; i++) { + for (work = gc->med_pages[i]; work; work = work->next) { + if (work->generation) { + reset_gen1_page(gc, work); + } + } + } + + flush_protect_page_ranges(gc->protect_range, 1); +} + +static void remove_gen1_page_from_pagemap(NewGC *gc, mpage *work) +{ + if (gc->generations_available && work->back_pointers && work->mprotected) { + work->mprotected = 0; + add_protect_page_range(gc->protect_range, work->addr, + (work->size_class > 1) ? round_to_apage_size(work->size) : APAGE_SIZE, + APAGE_SIZE, 1); + } + pagemap_remove(gc->page_maps, work); + work->added = 0; } static void remove_all_gen1_pages_from_pagemap(NewGC *gc) { - Page_Range *protect_range = gc->protect_range; - PageMap pagemap = gc->page_maps; mpage *work; int i; GCDEBUG((DEBUGOUTF, "MINOR COLLECTION - PREPPING PAGES - remove all gen1 pages from pagemap.\n")); + /* if we're not doing a major collection, then we need to remove all the pages in gc->gen1_pages[] from the page map */ + for(i = 0; i < PAGE_TYPES; i++) { for(work = gc->gen1_pages[i]; work; work = work->next) { - if (gc->generations_available && work->back_pointers && work->mprotected) { - work->mprotected = 0; - add_protect_page_range(protect_range, work->addr, work->big_page ? round_to_apage_size(work->size) : APAGE_SIZE, APAGE_SIZE, 1); - } - pagemap_remove(pagemap, work); - work->added = 0; + remove_gen1_page_from_pagemap(gc, work); } } - flush_protect_page_ranges(protect_range, 1); + + for (i = 0; i < NUM_MED_PAGE_SIZES; i++) { + for (work = gc->med_pages[i]; work; work = work->next) { + if (work->generation) { + remove_gen1_page_from_pagemap(gc, work); + } + } + } + + flush_protect_page_ranges(gc->protect_range, 1); } static void mark_backpointers(NewGC *gc) @@ -2151,7 +2364,7 @@ static void mark_backpointers(NewGC *gc) PageMap pagemap = gc->page_maps; /* if this is not a full collection, then we need to mark any pointers - which point backwards into generation 0, since they're roots. */ + that point backwards into generation 0, since they're roots. */ for(i = 0; i < PAGE_TYPES; i++) { for(work = gc->gen1_pages[i]; work; work = work->next) { if(work->back_pointers) { @@ -2160,8 +2373,9 @@ static void mark_backpointers(NewGC *gc) work->marked_on = 1; work->previous_size = PREFIX_SIZE; pagemap_add(pagemap, work); - if(work->big_page) { - work->big_page = 2; + if(work->size_class) { + /* must be a big page */ + work->size_class = 3; push_ptr(PPTR(NUM(work->addr) + PREFIX_SIZE + sizeof(struct objhead))); } else { if(work->page_type != PAGE_ATOMIC) { @@ -2185,11 +2399,33 @@ static void mark_backpointers(NewGC *gc) work->previous_size = PREFIX_SIZE; } else { GCDEBUG((DEBUGOUTF,"Setting previous_size on %p to %i\n", work, - work->size)); + work->size)); work->previous_size = work->size; } } } + + for (i = 0; i < NUM_MED_PAGE_SIZES; i++) { + for (work = gc->med_pages[i]; work; work = work->next) { + if(work->back_pointers) { + void **start = PPTR(NUM(work->addr) + PREFIX_SIZE); + void **end = PPTR(NUM(work->addr) + APAGE_SIZE - work->size); + + work->marked_on = 1; + pagemap_add(pagemap, work); + + while(start <= end) { + struct objhead *info = (struct objhead *)start; + if(!info->dead) { + info->mark = 1; + /* This must be a push_ptr (see above) */ + push_ptr(start + 1); + } + start += info->size; + } + } + } + } } } @@ -2202,7 +2438,7 @@ struct mpage *allocate_compact_target(NewGC *gc, mpage *work) npage->previous_size = npage->size = PREFIX_SIZE; npage->generation = 1; npage->back_pointers = 0; - npage->big_page = 0; + npage->size_class = 0; npage->page_type = work->page_type; npage->marked_on = 1; backtrace_new_page(gc, npage); @@ -2244,7 +2480,7 @@ inline static void do_heap_compact(NewGC *gc) unsigned long avail; GCDEBUG((DEBUGOUTF, "Compacting page %p: new version at %p\n", - work, npage)); + work, npage)); if (npage == work) { /* Need to insert a page: */ @@ -2276,7 +2512,7 @@ inline static void do_heap_compact(NewGC *gc) } GCDEBUG((DEBUGOUTF,"Moving size %i object from %p to %p\n", - gcWORDS_TO_BYTES(info->size), start+1, newplace+1)); + gcWORDS_TO_BYTES(info->size), start+1, newplace+1)); memcpy(newplace, start, gcWORDS_TO_BYTES(info->size)); info->moved = 1; *(PPTR(NUM(start) + WORD_SIZE)) = PTR(NUM(newplace) + WORD_SIZE); @@ -2324,30 +2560,31 @@ static void repair_heap(NewGC *gc) if(page->marked_on) { page->has_new = 0; /* these are guaranteed not to be protected */ - if(page->big_page) { + if(page->size_class) { + /* since we get here via gen1_pages, it's a big page */ void **start = PPTR(NUM(page->addr) + PREFIX_SIZE + WORD_SIZE); void **end = PPTR(NUM(page->addr) + page->size); GCDEBUG((DEBUGOUTF, "Cleaning objs on page %p, starting with %p\n", - page, start)); - page->big_page = 1; /* remove the mark */ + page, start)); + page->size_class = 2; /* remove the mark */ switch(page->page_type) { - case PAGE_TAGGED: - fixup_table[*(unsigned short*)start](start); - break; - case PAGE_ATOMIC: break; - case PAGE_ARRAY: - while(start < end) gcFIXUP(*(start++)); - break; - case PAGE_XTAGGED: - GC_fixup_xtagged(start); - break; - case PAGE_TARRAY: { - unsigned short tag = *(unsigned short *)start; - end -= INSET_WORDS; - while(start < end) start += fixup_table[tag](start); - break; - } + case PAGE_TAGGED: + fixup_table[*(unsigned short*)start](start); + break; + case PAGE_ATOMIC: break; + case PAGE_ARRAY: + while(start < end) gcFIXUP(*(start++)); + break; + case PAGE_XTAGGED: + GC_fixup_xtagged(start); + break; + case PAGE_TARRAY: { + unsigned short tag = *(unsigned short *)start; + end -= INSET_WORDS; + while(start < end) start += fixup_table[tag](start); + break; + } } } else { void **start = PPTR(NUM(page->addr) + page->previous_size); @@ -2423,10 +2660,43 @@ static void repair_heap(NewGC *gc) } else GCDEBUG((DEBUGOUTF,"Not Cleaning page %p\n", page)); } } + + for (i = 0; i < NUM_MED_PAGE_SIZES; i++) { + for (page = gc->med_pages[i]; page; page = page->next) { + if (page->marked_on) { + void **start = PPTR(NUM(page->addr) + PREFIX_SIZE); + void **end = PPTR(NUM(page->addr) + APAGE_SIZE - page->size); + + while(start <= end) { + struct objhead *info = (struct objhead *)start; + if(info->mark) { + switch(info->type) { + case PAGE_ARRAY: + { + void **tempend = (start++) + info->size; + while(start < tempend) gcFIXUP(*start++); + } + break; + case PAGE_TAGGED: + { + fixup_table[*(unsigned short*)(start+1)](start+1); + start += info->size; + } + break; + } + info->mark = 0; + } else { + info->dead = 1; + start += info->size; + } + } + } + } + } } static inline void gen1_free_mpage(PageMap pagemap, mpage *page) { - size_t real_page_size = page->big_page ? round_to_apage_size(page->size) : APAGE_SIZE; + size_t real_page_size = (page->size_class > 1) ? round_to_apage_size(page->size) : APAGE_SIZE; pagemap_remove(pagemap, page); free_backtrace(page); free_pages(GC, page->addr, real_page_size); @@ -2495,7 +2765,60 @@ static void clean_up_heap(NewGC *gc) } } } - + + for (i = 0; i < NUM_MED_PAGE_SIZES; i++) { + mpage *work; + mpage *prev = NULL, *next; + + for (work = gc->med_pages[i]; work; work = next) { + if (work->marked_on) { + void **start = PPTR(NUM(work->addr) + PREFIX_SIZE); + void **end = PPTR(NUM(work->addr) + APAGE_SIZE - work->size); + int non_dead = 0; + + while(start <= end) { + struct objhead *info = (struct objhead *)start; + if (!info->dead) { + non_dead++; + } + start += info->size; + } + + next = work->next; + if (non_dead) { + work->live_size = (work->size * non_dead); + memory_in_use += work->live_size; + work->previous_size = PREFIX_SIZE; + work->back_pointers = work->marked_on = 0; + work->generation = 1; + pagemap_add(pagemap, work); + prev = work; + } else { + /* free the page */ + if(prev) prev->next = next; else gc->med_pages[i] = next; + if(next) work->next->prev = prev; + gen1_free_mpage(pagemap, work); + } + } else if (gc->gc_full || !work->generation) { + /* Page wasn't touched in full GC, or gen-0 not touched, + so we can free it. */ + next = work->next; + if(prev) prev->next = next; else gc->med_pages[i] = next; + if(next) work->next->prev = prev; + gen1_free_mpage(pagemap, work); + } else { + /* not touched during minor gc */ + memory_in_use += work->live_size; + work->previous_size = PREFIX_SIZE; + next = work->next; + prev = work; + work->back_pointers = 0; + pagemap_add(pagemap, work); + } + } + gc->med_freelist_pages[i] = prev; + } + gc->memory_in_use = memory_in_use; cleanup_vacated_pages(gc); } @@ -2506,7 +2829,7 @@ static void protect_old_pages(NewGC *gc) struct mpage *page; int i; - for(i = 0; i < PAGE_TYPES; i++) + for(i = 0; i < PAGE_TYPES; i++) { if(i != PAGE_ATOMIC) for(page = gc->gen1_pages[i]; page; page = page->next) if(page->page_type != PAGE_ATOMIC) { @@ -2515,6 +2838,16 @@ static void protect_old_pages(NewGC *gc) add_protect_page_range(protect_range, page->addr, page->size, APAGE_SIZE, 0); } } + } + + for (i = 0; i < NUM_MED_PAGE_SIZES; i++) { + for (page = gc->med_pages[i]; page; page = page->next) { + if (!page->mprotected) { + page->mprotected = 1; + add_protect_page_range(protect_range, page->addr, APAGE_SIZE, APAGE_SIZE, 0); + } + } + } flush_protect_page_ranges(protect_range, 0); } @@ -2822,7 +3155,7 @@ void GC_free_all(void) next = work->next; if (work->mprotected) - vm_protect_pages(work->addr, work->big_page ? round_to_apage_size(work->size) : APAGE_SIZE, 1); + vm_protect_pages(work->addr, (work->size_class > 1) ? round_to_apage_size(work->size) : APAGE_SIZE, 1); gen1_free_mpage(pagemap, work); } } diff --git a/src/mzscheme/gc2/newgc.h b/src/mzscheme/gc2/newgc.h index 435dae0d11..d29d636933 100644 --- a/src/mzscheme/gc2/newgc.h +++ b/src/mzscheme/gc2/newgc.h @@ -5,8 +5,8 @@ typedef struct mpage { struct mpage *next; struct mpage *prev; void *addr; - unsigned long previous_size; - unsigned long size; + unsigned long previous_size; /* for med page, points to place to search for available block */ + unsigned long size; /* big page size or med page element size */ unsigned char generation; /* unsigned char back_pointers :1; @@ -17,7 +17,7 @@ typedef struct mpage { unsigned char mprotected :1; */ unsigned char back_pointers ; - unsigned char big_page ; + unsigned char size_class ; /* 1 => med; 2 => big; 3 => big marked */ unsigned char page_type ; unsigned char marked_on ; unsigned char has_new ; @@ -92,6 +92,8 @@ typedef mpage ****PageMap; typedef mpage **PageMap; #endif +#define NUM_MED_PAGE_SIZES (((LOG_APAGE_SIZE - 1) - 3) + 1) + typedef struct NewGC { Gen0 gen0; Mark_Proc *mark_table; /* the table of mark procs */ @@ -101,6 +103,8 @@ typedef struct NewGC { struct mpage *gen1_pages[PAGE_TYPES]; Page_Range *protect_range; + struct mpage *med_pages[NUM_MED_PAGE_SIZES]; + struct mpage *med_freelist_pages[NUM_MED_PAGE_SIZES]; /* Finalization */ Fnl *run_queue; diff --git a/src/mzscheme/src/cstartup.inc b/src/mzscheme/src/cstartup.inc index 106a7fda17..695378257d 100644 --- a/src/mzscheme/src/cstartup.inc +++ b/src/mzscheme/src/cstartup.inc @@ -1,10 +1,10 @@ { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,51,50,0,0,0,1,0,0,3,0,12,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,53,50,0,0,0,1,0,0,3,0,12,0, 17,0,20,0,27,0,40,0,47,0,51,0,58,0,63,0,68,0,72,0,78, 0,92,0,106,0,109,0,115,0,119,0,121,0,132,0,134,0,148,0,155,0, -177,0,179,0,193,0,253,0,23,1,32,1,41,1,51,1,87,1,126,1,165, -1,234,1,42,2,130,2,194,2,199,2,219,2,110,3,130,3,181,3,247,3, -132,4,34,5,84,5,107,5,186,5,0,0,132,7,0,0,29,11,11,68,104, +177,0,179,0,193,0,1,1,27,1,35,1,43,1,53,1,89,1,128,1,167, +1,236,1,44,2,132,2,196,2,201,2,221,2,112,3,132,3,183,3,249,3, +134,4,36,5,86,5,109,5,188,5,0,0,135,7,0,0,29,11,11,68,104, 101,114,101,45,115,116,120,64,99,111,110,100,62,111,114,66,108,101,116,114,101, 99,72,112,97,114,97,109,101,116,101,114,105,122,101,66,117,110,108,101,115,115, 63,108,101,116,66,100,101,102,105,110,101,64,119,104,101,110,64,108,101,116,42, @@ -13,100 +13,100 @@ 98,101,103,105,110,63,115,116,120,61,115,70,108,101,116,45,118,97,108,117,101, 115,61,120,73,108,101,116,114,101,99,45,118,97,108,117,101,115,66,108,97,109, 98,100,97,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110, -45,107,101,121,61,118,73,100,101,102,105,110,101,45,118,97,108,117,101,115,98, -10,35,11,8,165,228,94,159,2,15,35,35,159,2,14,35,35,16,20,2,3, -2,1,2,5,2,1,2,6,2,1,2,7,2,1,2,8,2,1,2,9,2, -1,2,10,2,1,2,4,2,1,2,11,2,1,2,12,2,1,97,36,11,8, -165,228,93,159,2,14,35,36,16,2,2,2,161,2,1,36,2,2,2,1,2, -2,97,10,11,11,8,165,228,16,0,97,10,37,11,8,165,228,16,0,13,16, -4,35,29,11,11,2,1,11,18,16,2,99,64,104,101,114,101,8,31,8,30, -8,29,8,28,8,27,93,8,224,44,57,0,0,95,9,8,224,44,57,0,0, -2,1,27,248,22,135,4,23,196,1,249,22,128,4,80,158,38,35,251,22,75, -2,16,248,22,90,23,200,2,12,249,22,65,2,17,248,22,92,23,202,1,27, -248,22,135,4,23,196,1,249,22,128,4,80,158,38,35,251,22,75,2,16,248, -22,90,23,200,2,249,22,65,2,17,248,22,92,23,202,1,12,27,248,22,67, -248,22,135,4,23,197,1,28,248,22,73,23,194,2,20,15,159,36,35,36,28, -248,22,73,248,22,67,23,195,2,248,22,66,193,249,22,128,4,80,158,38,35, -251,22,75,2,16,248,22,66,23,200,2,249,22,65,2,12,248,22,67,23,202, -1,11,18,16,2,101,10,8,31,8,30,8,29,8,28,8,27,16,4,11,11, -2,18,3,1,7,101,110,118,57,56,50,51,16,4,11,11,2,19,3,1,7, -101,110,118,57,56,50,52,93,8,224,45,57,0,0,95,9,8,224,45,57,0, -0,2,1,27,248,22,67,248,22,135,4,23,197,1,28,248,22,73,23,194,2, -20,15,159,36,35,36,28,248,22,73,248,22,67,23,195,2,248,22,66,193,249, -22,128,4,80,158,38,35,250,22,75,2,20,248,22,75,249,22,75,248,22,75, -2,21,248,22,66,23,202,2,251,22,75,2,16,2,21,2,21,249,22,65,2, -4,248,22,67,23,205,1,18,16,2,101,11,8,31,8,30,8,29,8,28,8, -27,16,4,11,11,2,18,3,1,7,101,110,118,57,56,50,54,16,4,11,11, -2,19,3,1,7,101,110,118,57,56,50,55,93,8,224,46,57,0,0,95,9, -8,224,46,57,0,0,2,1,248,22,135,4,193,27,248,22,135,4,194,249,22, -65,248,22,75,248,22,66,196,248,22,67,195,27,248,22,67,248,22,135,4,23, -197,1,249,22,128,4,80,158,38,35,28,248,22,53,248,22,129,4,248,22,66, -23,198,2,27,249,22,2,32,0,89,162,8,44,36,42,9,222,33,39,248,22, -135,4,248,22,90,23,200,2,250,22,75,2,22,248,22,75,249,22,75,248,22, -75,248,22,66,23,204,2,250,22,76,2,23,249,22,2,22,66,23,204,2,248, -22,92,23,206,2,249,22,65,248,22,66,23,202,1,249,22,2,22,90,23,200, -1,250,22,76,2,20,249,22,2,32,0,89,162,8,44,36,46,9,222,33,40, -248,22,135,4,248,22,66,201,248,22,67,198,27,248,22,135,4,194,249,22,65, -248,22,75,248,22,66,196,248,22,67,195,27,248,22,67,248,22,135,4,23,197, -1,249,22,128,4,80,158,38,35,250,22,76,2,22,249,22,2,32,0,89,162, -8,44,36,46,9,222,33,42,248,22,135,4,248,22,66,201,248,22,67,198,27, -248,22,67,248,22,135,4,196,27,248,22,135,4,248,22,66,195,249,22,128,4, -80,158,39,35,28,248,22,73,195,250,22,76,2,20,9,248,22,67,199,250,22, -75,2,8,248,22,75,248,22,66,199,250,22,76,2,11,248,22,67,201,248,22, -67,202,27,248,22,67,248,22,135,4,23,197,1,27,249,22,1,22,79,249,22, -2,22,135,4,248,22,135,4,248,22,66,199,249,22,128,4,80,158,39,35,251, -22,75,1,22,119,105,116,104,45,99,111,110,116,105,110,117,97,116,105,111,110, -45,109,97,114,107,2,24,250,22,76,1,23,101,120,116,101,110,100,45,112,97, -114,97,109,101,116,101,114,105,122,97,116,105,111,110,21,95,1,27,99,111,110, -116,105,110,117,97,116,105,111,110,45,109,97,114,107,45,115,101,116,45,102,105, -114,115,116,11,2,24,201,250,22,76,2,20,9,248,22,67,203,27,248,22,67, -248,22,135,4,23,197,1,28,248,22,73,23,194,2,20,15,159,36,35,36,249, -22,128,4,80,158,38,35,27,248,22,135,4,248,22,66,23,198,2,28,249,22, -164,8,62,61,62,248,22,129,4,248,22,90,23,197,2,250,22,75,2,20,248, -22,75,249,22,75,21,93,2,25,248,22,66,199,250,22,76,2,3,249,22,75, -2,25,249,22,75,248,22,99,203,2,25,248,22,67,202,251,22,75,2,16,28, -249,22,164,8,248,22,129,4,248,22,66,23,201,2,64,101,108,115,101,10,248, -22,66,23,198,2,250,22,76,2,20,9,248,22,67,23,201,1,249,22,65,2, -3,248,22,67,23,203,1,100,8,31,8,30,8,29,8,28,8,27,16,4,11, -11,2,18,3,1,7,101,110,118,57,56,52,57,16,4,11,11,2,19,3,1, -7,101,110,118,57,56,53,48,93,8,224,47,57,0,0,18,16,2,158,94,10, -64,118,111,105,100,8,47,95,9,8,224,47,57,0,0,2,1,27,248,22,67, -248,22,135,4,196,249,22,128,4,80,158,38,35,28,248,22,53,248,22,129,4, -248,22,66,197,250,22,75,2,26,248,22,75,248,22,66,199,248,22,90,198,27, -248,22,129,4,248,22,66,197,250,22,75,2,26,248,22,75,248,22,66,197,250, -22,76,2,23,248,22,67,199,248,22,67,202,159,35,20,103,159,35,16,1,11, -16,0,83,158,41,20,100,143,69,35,37,109,105,110,45,115,116,120,2,1,11, -10,11,10,35,80,158,35,35,20,103,159,35,16,0,16,0,11,11,16,1,2, -2,36,16,0,35,16,0,35,11,11,38,35,11,11,16,10,2,3,2,4,2, -5,2,6,2,7,2,8,2,9,2,10,2,11,2,12,16,10,11,11,11,11, -11,11,11,11,11,11,16,10,2,3,2,4,2,5,2,6,2,7,2,8,2, -9,2,10,2,11,2,12,35,45,36,11,11,16,0,16,0,16,0,35,35,11, -11,11,16,0,16,0,16,0,35,35,16,11,16,5,2,2,20,15,159,35,35, -35,35,20,103,159,35,16,0,16,1,33,32,10,16,5,2,7,89,162,8,44, -36,52,9,223,0,33,33,35,20,103,159,35,16,1,2,2,16,0,11,16,5, -2,10,89,162,8,44,36,52,9,223,0,33,34,35,20,103,159,35,16,1,2, -2,16,0,11,16,5,2,12,89,162,8,44,36,52,9,223,0,33,35,35,20, -103,159,35,16,1,2,2,16,1,33,36,11,16,5,2,4,89,162,8,44,36, -55,9,223,0,33,37,35,20,103,159,35,16,1,2,2,16,1,33,38,11,16, -5,2,8,89,162,8,44,36,57,9,223,0,33,41,35,20,103,159,35,16,1, -2,2,16,0,11,16,5,2,5,89,162,8,44,36,52,9,223,0,33,43,35, -20,103,159,35,16,1,2,2,16,0,11,16,5,2,11,89,162,8,44,36,53, -9,223,0,33,44,35,20,103,159,35,16,1,2,2,16,0,11,16,5,2,6, -89,162,8,44,36,54,9,223,0,33,45,35,20,103,159,35,16,1,2,2,16, -0,11,16,5,2,3,89,162,8,44,36,57,9,223,0,33,46,35,20,103,159, -35,16,1,2,2,16,1,33,48,11,16,5,2,9,89,162,8,44,36,53,9, -223,0,33,49,35,20,103,159,35,16,1,2,2,16,0,11,16,0,94,2,14, -2,15,93,2,14,9,9,35,0}; - EVAL_ONE_SIZED_STR((char *)expr, 2045); +45,107,101,121,61,118,73,100,101,102,105,110,101,45,118,97,108,117,101,115,97, +35,11,8,168,228,95,159,2,15,35,35,159,2,14,35,35,159,2,14,35,35, +16,20,2,3,2,1,2,5,2,1,2,6,2,1,2,7,2,1,2,8,2, +1,2,9,2,1,2,10,2,1,2,4,2,1,2,11,2,1,2,12,2,1, +97,36,11,8,168,228,93,159,2,14,35,36,16,2,2,2,161,2,1,36,2, +2,2,1,2,2,96,11,11,8,168,228,16,0,96,37,11,8,168,228,16,0, +13,16,4,35,29,11,11,2,1,11,18,16,2,99,64,104,101,114,101,8,31, +8,30,8,29,8,28,8,27,93,8,224,47,57,0,0,95,9,8,224,47,57, +0,0,2,1,27,248,22,135,4,23,196,1,249,22,128,4,80,158,38,35,251, +22,75,2,16,248,22,90,23,200,2,12,249,22,65,2,17,248,22,92,23,202, +1,27,248,22,135,4,23,196,1,249,22,128,4,80,158,38,35,251,22,75,2, +16,248,22,90,23,200,2,249,22,65,2,17,248,22,92,23,202,1,12,27,248, +22,67,248,22,135,4,23,197,1,28,248,22,73,23,194,2,20,15,159,36,35, +36,28,248,22,73,248,22,67,23,195,2,248,22,66,193,249,22,128,4,80,158, +38,35,251,22,75,2,16,248,22,66,23,200,2,249,22,65,2,12,248,22,67, +23,202,1,11,18,16,2,101,10,8,31,8,30,8,29,8,28,8,27,16,4, +11,11,2,18,3,1,7,101,110,118,57,56,49,54,16,4,11,11,2,19,3, +1,7,101,110,118,57,56,49,55,93,8,224,48,57,0,0,95,9,8,224,48, +57,0,0,2,1,27,248,22,67,248,22,135,4,23,197,1,28,248,22,73,23, +194,2,20,15,159,36,35,36,28,248,22,73,248,22,67,23,195,2,248,22,66, +193,249,22,128,4,80,158,38,35,250,22,75,2,20,248,22,75,249,22,75,248, +22,75,2,21,248,22,66,23,202,2,251,22,75,2,16,2,21,2,21,249,22, +65,2,4,248,22,67,23,205,1,18,16,2,101,11,8,31,8,30,8,29,8, +28,8,27,16,4,11,11,2,18,3,1,7,101,110,118,57,56,49,57,16,4, +11,11,2,19,3,1,7,101,110,118,57,56,50,48,93,8,224,49,57,0,0, +95,9,8,224,49,57,0,0,2,1,248,22,135,4,193,27,248,22,135,4,194, +249,22,65,248,22,75,248,22,66,196,248,22,67,195,27,248,22,67,248,22,135, +4,23,197,1,249,22,128,4,80,158,38,35,28,248,22,53,248,22,129,4,248, +22,66,23,198,2,27,249,22,2,32,0,89,162,8,44,36,42,9,222,33,39, +248,22,135,4,248,22,90,23,200,2,250,22,75,2,22,248,22,75,249,22,75, +248,22,75,248,22,66,23,204,2,250,22,76,2,23,249,22,2,22,66,23,204, +2,248,22,92,23,206,2,249,22,65,248,22,66,23,202,1,249,22,2,22,90, +23,200,1,250,22,76,2,20,249,22,2,32,0,89,162,8,44,36,46,9,222, +33,40,248,22,135,4,248,22,66,201,248,22,67,198,27,248,22,135,4,194,249, +22,65,248,22,75,248,22,66,196,248,22,67,195,27,248,22,67,248,22,135,4, +23,197,1,249,22,128,4,80,158,38,35,250,22,76,2,22,249,22,2,32,0, +89,162,8,44,36,46,9,222,33,42,248,22,135,4,248,22,66,201,248,22,67, +198,27,248,22,67,248,22,135,4,196,27,248,22,135,4,248,22,66,195,249,22, +128,4,80,158,39,35,28,248,22,73,195,250,22,76,2,20,9,248,22,67,199, +250,22,75,2,8,248,22,75,248,22,66,199,250,22,76,2,11,248,22,67,201, +248,22,67,202,27,248,22,67,248,22,135,4,23,197,1,27,249,22,1,22,79, +249,22,2,22,135,4,248,22,135,4,248,22,66,199,249,22,128,4,80,158,39, +35,251,22,75,1,22,119,105,116,104,45,99,111,110,116,105,110,117,97,116,105, +111,110,45,109,97,114,107,2,24,250,22,76,1,23,101,120,116,101,110,100,45, +112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,21,95,1,27,99, +111,110,116,105,110,117,97,116,105,111,110,45,109,97,114,107,45,115,101,116,45, +102,105,114,115,116,11,2,24,201,250,22,76,2,20,9,248,22,67,203,27,248, +22,67,248,22,135,4,23,197,1,28,248,22,73,23,194,2,20,15,159,36,35, +36,249,22,128,4,80,158,38,35,27,248,22,135,4,248,22,66,23,198,2,28, +249,22,164,8,62,61,62,248,22,129,4,248,22,90,23,197,2,250,22,75,2, +20,248,22,75,249,22,75,21,93,2,25,248,22,66,199,250,22,76,2,3,249, +22,75,2,25,249,22,75,248,22,99,203,2,25,248,22,67,202,251,22,75,2, +16,28,249,22,164,8,248,22,129,4,248,22,66,23,201,2,64,101,108,115,101, +10,248,22,66,23,198,2,250,22,76,2,20,9,248,22,67,23,201,1,249,22, +65,2,3,248,22,67,23,203,1,100,8,31,8,30,8,29,8,28,8,27,16, +4,11,11,2,18,3,1,7,101,110,118,57,56,52,50,16,4,11,11,2,19, +3,1,7,101,110,118,57,56,52,51,93,8,224,50,57,0,0,18,16,2,158, +94,10,64,118,111,105,100,8,47,95,9,8,224,50,57,0,0,2,1,27,248, +22,67,248,22,135,4,196,249,22,128,4,80,158,38,35,28,248,22,53,248,22, +129,4,248,22,66,197,250,22,75,2,26,248,22,75,248,22,66,199,248,22,90, +198,27,248,22,129,4,248,22,66,197,250,22,75,2,26,248,22,75,248,22,66, +197,250,22,76,2,23,248,22,67,199,248,22,67,202,159,35,20,103,159,35,16, +1,11,16,0,83,158,41,20,100,144,69,35,37,109,105,110,45,115,116,120,2, +1,11,11,11,10,35,80,158,35,35,20,103,159,35,16,0,16,0,16,1,2, +2,36,16,0,35,16,0,35,11,11,38,35,11,11,11,16,10,2,3,2,4, +2,5,2,6,2,7,2,8,2,9,2,10,2,11,2,12,16,10,11,11,11, +11,11,11,11,11,11,11,16,10,2,3,2,4,2,5,2,6,2,7,2,8, +2,9,2,10,2,11,2,12,35,45,36,11,11,11,16,0,16,0,16,0,35, +35,11,11,11,11,16,0,16,0,16,0,35,35,16,11,16,5,2,2,20,15, +159,35,35,35,35,20,103,159,35,16,0,16,1,33,32,10,16,5,2,7,89, +162,8,44,36,52,9,223,0,33,33,35,20,103,159,35,16,1,2,2,16,0, +11,16,5,2,10,89,162,8,44,36,52,9,223,0,33,34,35,20,103,159,35, +16,1,2,2,16,0,11,16,5,2,12,89,162,8,44,36,52,9,223,0,33, +35,35,20,103,159,35,16,1,2,2,16,1,33,36,11,16,5,2,4,89,162, +8,44,36,55,9,223,0,33,37,35,20,103,159,35,16,1,2,2,16,1,33, +38,11,16,5,2,8,89,162,8,44,36,57,9,223,0,33,41,35,20,103,159, +35,16,1,2,2,16,0,11,16,5,2,5,89,162,8,44,36,52,9,223,0, +33,43,35,20,103,159,35,16,1,2,2,16,0,11,16,5,2,11,89,162,8, +44,36,53,9,223,0,33,44,35,20,103,159,35,16,1,2,2,16,0,11,16, +5,2,6,89,162,8,44,36,54,9,223,0,33,45,35,20,103,159,35,16,1, +2,2,16,0,11,16,5,2,3,89,162,8,44,36,57,9,223,0,33,46,35, +20,103,159,35,16,1,2,2,16,1,33,48,11,16,5,2,9,89,162,8,44, +36,53,9,223,0,33,49,35,20,103,159,35,16,1,2,2,16,0,11,16,0, +94,2,14,2,15,93,2,14,9,9,35,0}; + EVAL_ONE_SIZED_STR((char *)expr, 2048); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,51,59,0,0,0,1,0,0,13,0,18,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,53,59,0,0,0,1,0,0,13,0,18,0, 35,0,50,0,68,0,84,0,94,0,112,0,132,0,148,0,166,0,197,0,226, 0,248,0,6,1,12,1,26,1,31,1,41,1,49,1,77,1,109,1,154,1, 199,1,223,1,6,2,8,2,65,2,155,3,196,3,31,5,135,5,239,5,100, 6,114,6,148,6,164,6,14,8,28,8,191,8,194,9,194,10,201,10,208,10, 215,10,90,11,103,11,58,12,160,12,173,12,195,12,147,13,51,14,123,15,131, -15,139,15,165,15,20,16,0,0,8,19,0,0,72,112,97,116,104,45,115,116, +15,139,15,165,15,20,16,0,0,9,19,0,0,72,112,97,116,104,45,115,116, 114,105,110,103,63,64,98,115,98,115,76,110,111,114,109,97,108,45,99,97,115, 101,45,112,97,116,104,74,45,99,104,101,99,107,45,114,101,108,112,97,116,104, 77,45,99,104,101,99,107,45,99,111,108,108,101,99,116,105,111,110,75,99,111, @@ -303,69 +303,69 @@ 175,3,23,202,1,28,192,192,35,249,22,153,5,23,197,1,83,158,39,20,97, 95,89,162,8,44,35,47,9,224,3,2,33,57,23,195,1,23,196,1,27,248, 22,138,5,23,195,1,248,80,159,38,53,36,193,159,35,20,103,159,35,16,1, -11,16,0,83,158,41,20,100,143,67,35,37,117,116,105,108,115,29,11,11,11, -11,10,10,42,80,158,35,35,20,103,159,37,16,17,2,1,2,2,2,3,2, +11,16,0,83,158,41,20,100,144,67,35,37,117,116,105,108,115,29,11,11,11, +11,11,10,42,80,158,35,35,20,103,159,37,16,17,2,1,2,2,2,3,2, 4,2,5,2,6,2,7,2,8,2,9,2,10,2,11,2,12,2,13,2,14, 2,15,30,2,17,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105, 111,110,45,107,101,121,4,30,2,17,1,23,101,120,116,101,110,100,45,112,97, -114,97,109,101,116,101,114,105,122,97,116,105,111,110,3,16,0,11,11,16,0, -35,16,0,35,16,4,2,5,2,4,2,2,2,8,39,11,11,38,35,11,11, -16,11,2,7,2,6,2,15,2,14,2,12,2,11,2,3,2,10,2,13,2, -9,2,1,16,11,11,11,11,11,11,11,11,11,11,11,11,16,11,2,7,2, -6,2,15,2,14,2,12,2,11,2,3,2,10,2,13,2,9,2,1,46,46, -36,11,11,16,0,16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35, -35,16,0,16,17,83,158,35,16,2,89,162,43,36,48,2,18,223,0,33,28, -80,159,35,53,36,83,158,35,16,2,89,162,8,44,36,55,2,18,223,0,33, -29,80,159,35,52,36,83,158,35,16,2,32,0,89,162,43,36,44,2,1,222, -33,30,80,159,35,35,36,83,158,35,16,2,249,22,161,6,7,92,7,92,80, -159,35,36,36,83,158,35,16,2,89,162,43,36,53,2,3,223,0,33,31,80, -159,35,37,36,83,158,35,16,2,32,0,89,162,8,44,37,49,2,4,222,33, -32,80,159,35,38,36,83,158,35,16,2,32,0,89,162,8,44,38,50,2,5, -222,33,34,80,159,35,39,36,83,158,35,16,2,89,162,8,45,37,47,2,6, -223,0,33,36,80,159,35,40,36,83,158,35,16,2,32,0,89,162,43,39,51, -2,7,222,33,39,80,159,35,41,36,83,158,35,16,2,32,0,89,162,43,38, -49,2,8,222,33,40,80,159,35,42,36,83,158,35,16,2,32,0,89,162,43, -37,52,2,9,222,33,41,80,159,35,43,36,83,158,35,16,2,32,0,89,162, -43,37,53,2,10,222,33,42,80,159,35,44,36,83,158,35,16,2,32,0,89, -162,43,36,43,2,11,222,33,43,80,159,35,45,36,83,158,35,16,2,83,158, -38,20,96,96,2,12,89,162,43,35,43,9,223,0,33,44,89,162,43,36,44, -9,223,0,33,45,89,162,43,37,54,9,223,0,33,46,80,159,35,46,36,83, -158,35,16,2,27,248,22,187,13,248,22,170,7,27,28,249,22,164,8,247,22, -178,7,2,20,6,1,1,59,6,1,1,58,250,22,143,7,6,14,14,40,91, -94,126,97,93,42,41,126,97,40,46,42,41,23,196,2,23,196,1,89,162,8, -44,37,47,2,13,223,0,33,49,80,159,35,47,36,83,158,35,16,2,83,158, -38,20,96,96,2,14,89,162,8,44,38,53,9,223,0,33,54,89,162,43,37, -46,9,223,0,33,55,89,162,43,36,45,9,223,0,33,56,80,159,35,48,36, -83,158,35,16,2,89,162,43,38,51,2,15,223,0,33,58,80,159,35,49,36, -94,29,94,2,16,68,35,37,107,101,114,110,101,108,11,29,94,2,16,69,35, -37,109,105,110,45,115,116,120,11,9,9,9,35,0}; - EVAL_ONE_SIZED_STR((char *)expr, 5011); +114,97,109,101,116,101,114,105,122,97,116,105,111,110,3,16,0,16,0,35,16, +0,35,16,4,2,5,2,4,2,2,2,8,39,11,11,38,35,11,11,11,16, +11,2,7,2,6,2,15,2,14,2,12,2,11,2,3,2,10,2,13,2,9, +2,1,16,11,11,11,11,11,11,11,11,11,11,11,11,16,11,2,7,2,6, +2,15,2,14,2,12,2,11,2,3,2,10,2,13,2,9,2,1,46,46,36, +11,11,11,16,0,16,0,16,0,35,35,11,11,11,11,16,0,16,0,16,0, +35,35,16,0,16,17,83,158,35,16,2,89,162,43,36,48,2,18,223,0,33, +28,80,159,35,53,36,83,158,35,16,2,89,162,8,44,36,55,2,18,223,0, +33,29,80,159,35,52,36,83,158,35,16,2,32,0,89,162,43,36,44,2,1, +222,33,30,80,159,35,35,36,83,158,35,16,2,249,22,161,6,7,92,7,92, +80,159,35,36,36,83,158,35,16,2,89,162,43,36,53,2,3,223,0,33,31, +80,159,35,37,36,83,158,35,16,2,32,0,89,162,8,44,37,49,2,4,222, +33,32,80,159,35,38,36,83,158,35,16,2,32,0,89,162,8,44,38,50,2, +5,222,33,34,80,159,35,39,36,83,158,35,16,2,89,162,8,45,37,47,2, +6,223,0,33,36,80,159,35,40,36,83,158,35,16,2,32,0,89,162,43,39, +51,2,7,222,33,39,80,159,35,41,36,83,158,35,16,2,32,0,89,162,43, +38,49,2,8,222,33,40,80,159,35,42,36,83,158,35,16,2,32,0,89,162, +43,37,52,2,9,222,33,41,80,159,35,43,36,83,158,35,16,2,32,0,89, +162,43,37,53,2,10,222,33,42,80,159,35,44,36,83,158,35,16,2,32,0, +89,162,43,36,43,2,11,222,33,43,80,159,35,45,36,83,158,35,16,2,83, +158,38,20,96,96,2,12,89,162,43,35,43,9,223,0,33,44,89,162,43,36, +44,9,223,0,33,45,89,162,43,37,54,9,223,0,33,46,80,159,35,46,36, +83,158,35,16,2,27,248,22,187,13,248,22,170,7,27,28,249,22,164,8,247, +22,178,7,2,20,6,1,1,59,6,1,1,58,250,22,143,7,6,14,14,40, +91,94,126,97,93,42,41,126,97,40,46,42,41,23,196,2,23,196,1,89,162, +8,44,37,47,2,13,223,0,33,49,80,159,35,47,36,83,158,35,16,2,83, +158,38,20,96,96,2,14,89,162,8,44,38,53,9,223,0,33,54,89,162,43, +37,46,9,223,0,33,55,89,162,43,36,45,9,223,0,33,56,80,159,35,48, +36,83,158,35,16,2,89,162,43,38,51,2,15,223,0,33,58,80,159,35,49, +36,94,29,94,2,16,68,35,37,107,101,114,110,101,108,11,29,94,2,16,69, +35,37,109,105,110,45,115,116,120,11,9,9,9,35,0}; + EVAL_ONE_SIZED_STR((char *)expr, 5012); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,51,8,0,0,0,1,0,0,6,0,19,0, -34,0,48,0,62,0,76,0,111,0,0,0,1,1,0,0,65,113,117,111,116, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,53,8,0,0,0,1,0,0,6,0,19,0, +34,0,48,0,62,0,76,0,115,0,0,0,6,1,0,0,65,113,117,111,116, 101,29,94,2,1,67,35,37,117,116,105,108,115,11,29,94,2,1,69,35,37, 110,101,116,119,111,114,107,11,29,94,2,1,68,35,37,112,97,114,97,109,122, 11,29,94,2,1,68,35,37,101,120,112,111,98,115,11,29,94,2,1,68,35, -37,107,101,114,110,101,108,11,98,10,35,11,8,171,230,97,159,2,2,35,35, -159,2,3,35,35,159,2,4,35,35,159,2,5,35,35,159,2,6,35,35,16, -0,159,35,20,103,159,35,16,1,11,16,0,83,158,41,20,100,143,69,35,37, -98,117,105,108,116,105,110,29,11,11,11,10,10,18,96,11,42,42,42,35,80, -158,35,35,20,103,159,35,16,0,16,0,11,11,16,0,35,16,0,35,16,0, -35,11,11,38,35,11,11,16,0,16,0,16,0,35,35,36,11,11,16,0,16, -0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,35,16,0,16,0,99, -2,6,2,5,29,94,2,1,69,35,37,102,111,114,101,105,103,110,11,2,4, -2,3,2,2,29,94,2,1,67,35,37,112,108,97,99,101,11,9,9,9,35, -0}; - EVAL_ONE_SIZED_STR((char *)expr, 294); +37,107,101,114,110,101,108,11,97,35,11,8,174,230,98,159,2,2,35,35,159, +2,3,35,35,159,2,4,35,35,159,2,5,35,35,159,2,6,35,35,159,2, +6,35,35,16,0,159,35,20,103,159,35,16,1,11,16,0,83,158,41,20,100, +144,69,35,37,98,117,105,108,116,105,110,29,11,11,11,11,11,18,96,11,42, +42,42,35,80,158,35,35,20,103,159,35,16,0,16,0,16,0,35,16,0,35, +16,0,35,11,11,38,35,11,11,11,16,0,16,0,16,0,35,35,36,11,11, +11,16,0,16,0,16,0,35,35,11,11,11,11,16,0,16,0,16,0,35,35, +16,0,16,0,99,2,6,2,5,29,94,2,1,69,35,37,102,111,114,101,105, +103,110,11,2,4,2,3,2,2,29,94,2,1,67,35,37,112,108,97,99,101, +11,9,9,9,35,0}; + EVAL_ONE_SIZED_STR((char *)expr, 299); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,51,52,0,0,0,1,0,0,11,0,38,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,53,52,0,0,0,1,0,0,11,0,38,0, 44,0,57,0,71,0,93,0,119,0,131,0,149,0,169,0,181,0,197,0,220, 0,0,1,5,1,10,1,15,1,24,1,29,1,60,1,64,1,72,1,81,1, 89,1,192,1,237,1,1,2,30,2,61,2,117,2,127,2,174,2,184,2,191, 2,78,4,91,4,110,4,229,4,241,4,137,5,151,5,17,6,23,6,37,6, -64,6,149,6,151,6,217,6,172,12,231,12,9,13,0,0,144,15,0,0,70, +64,6,149,6,151,6,217,6,172,12,231,12,9,13,0,0,145,15,0,0,70, 100,108,108,45,115,117,102,102,105,120,1,25,100,101,102,97,117,108,116,45,108, 111,97,100,47,117,115,101,45,99,111,109,112,105,108,101,100,65,113,117,111,116, 101,29,94,2,3,67,35,37,117,116,105,108,115,11,29,94,2,3,68,35,37, @@ -525,8 +525,8 @@ 33,42,89,162,43,38,48,9,223,1,33,43,89,162,43,39,8,30,9,225,2, 3,0,33,49,208,87,95,248,22,152,4,248,80,159,37,49,37,247,22,188,11, 248,22,190,4,80,159,36,36,37,248,22,179,12,80,159,36,41,36,159,35,20, -103,159,35,16,1,11,16,0,83,158,41,20,100,143,66,35,37,98,111,111,116, -29,11,11,11,11,10,10,36,80,158,35,35,20,103,159,39,16,19,2,1,2, +103,159,35,16,1,11,16,0,83,158,41,20,100,144,66,35,37,98,111,111,116, +29,11,11,11,11,11,10,36,80,158,35,35,20,103,159,39,16,19,2,1,2, 2,30,2,4,72,112,97,116,104,45,115,116,114,105,110,103,63,10,30,2,4, 75,112,97,116,104,45,97,100,100,45,115,117,102,102,105,120,7,30,2,5,1, 20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,45,107,101,121, @@ -535,26 +535,26 @@ 2,12,2,13,2,14,30,2,4,69,45,102,105,110,100,45,99,111,108,0,30, 2,4,76,110,111,114,109,97,108,45,99,97,115,101,45,112,97,116,104,6,30, 2,4,79,112,97,116,104,45,114,101,112,108,97,99,101,45,115,117,102,102,105, -120,9,2,15,16,0,11,11,16,0,35,16,0,35,16,11,2,9,2,10,2, -7,2,8,2,11,2,12,2,2,2,6,2,1,2,14,2,13,46,11,11,38, -35,11,11,16,1,2,15,16,1,11,16,1,2,15,36,36,36,11,11,16,0, -16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,35,16,0,16,16, -83,158,35,16,2,89,162,43,36,44,9,223,0,33,23,80,159,35,57,36,83, -158,35,16,2,89,162,43,36,44,9,223,0,33,24,80,159,35,56,36,83,158, -35,16,2,89,162,43,36,48,67,103,101,116,45,100,105,114,223,0,33,25,80, -159,35,55,36,83,158,35,16,2,89,162,43,37,48,68,119,105,116,104,45,100, -105,114,223,0,33,26,80,159,35,54,36,83,158,35,16,2,248,22,178,7,69, -115,111,45,115,117,102,102,105,120,80,159,35,35,36,83,158,35,16,2,89,162, -43,37,59,2,2,223,0,33,35,80,159,35,36,36,83,158,35,16,2,32,0, -89,162,8,44,36,41,2,6,222,192,80,159,35,41,36,83,158,35,16,2,247, -22,126,80,159,35,42,36,83,158,35,16,2,247,22,125,80,159,35,43,36,83, -158,35,16,2,247,22,61,80,159,35,44,36,83,158,35,16,2,248,22,18,74, -109,111,100,117,108,101,45,108,111,97,100,105,110,103,80,159,35,45,36,83,158, -35,16,2,11,80,158,35,46,83,158,35,16,2,11,80,158,35,47,83,158,35, -16,2,32,0,89,162,43,37,44,2,13,222,33,41,80,159,35,48,36,83,158, -35,16,2,89,162,8,44,36,44,2,14,223,0,33,50,80,159,35,49,36,83, -158,35,16,2,89,162,43,35,43,2,15,223,0,33,51,80,159,35,53,36,95, -29,94,2,3,68,35,37,107,101,114,110,101,108,11,29,94,2,3,69,35,37, -109,105,110,45,115,116,120,11,2,4,9,9,9,35,0}; - EVAL_ONE_SIZED_STR((char *)expr, 4109); +120,9,2,15,16,0,16,0,35,16,0,35,16,11,2,9,2,10,2,7,2, +8,2,11,2,12,2,2,2,6,2,1,2,14,2,13,46,11,11,38,35,11, +11,11,16,1,2,15,16,1,11,16,1,2,15,36,36,36,11,11,11,16,0, +16,0,16,0,35,35,11,11,11,11,16,0,16,0,16,0,35,35,16,0,16, +16,83,158,35,16,2,89,162,43,36,44,9,223,0,33,23,80,159,35,57,36, +83,158,35,16,2,89,162,43,36,44,9,223,0,33,24,80,159,35,56,36,83, +158,35,16,2,89,162,43,36,48,67,103,101,116,45,100,105,114,223,0,33,25, +80,159,35,55,36,83,158,35,16,2,89,162,43,37,48,68,119,105,116,104,45, +100,105,114,223,0,33,26,80,159,35,54,36,83,158,35,16,2,248,22,178,7, +69,115,111,45,115,117,102,102,105,120,80,159,35,35,36,83,158,35,16,2,89, +162,43,37,59,2,2,223,0,33,35,80,159,35,36,36,83,158,35,16,2,32, +0,89,162,8,44,36,41,2,6,222,192,80,159,35,41,36,83,158,35,16,2, +247,22,126,80,159,35,42,36,83,158,35,16,2,247,22,125,80,159,35,43,36, +83,158,35,16,2,247,22,61,80,159,35,44,36,83,158,35,16,2,248,22,18, +74,109,111,100,117,108,101,45,108,111,97,100,105,110,103,80,159,35,45,36,83, +158,35,16,2,11,80,158,35,46,83,158,35,16,2,11,80,158,35,47,83,158, +35,16,2,32,0,89,162,43,37,44,2,13,222,33,41,80,159,35,48,36,83, +158,35,16,2,89,162,8,44,36,44,2,14,223,0,33,50,80,159,35,49,36, +83,158,35,16,2,89,162,43,35,43,2,15,223,0,33,51,80,159,35,53,36, +95,29,94,2,3,68,35,37,107,101,114,110,101,108,11,29,94,2,3,69,35, +37,109,105,110,45,115,116,120,11,2,4,9,9,9,35,0}; + EVAL_ONE_SIZED_STR((char *)expr, 4110); } diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index cb9819e962..d9dd2994b8 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -1180,6 +1180,7 @@ void scheme_shadow(Scheme_Env *env, Scheme_Object *n, int stxtoo) env->mod_phase, NULL, NULL, + NULL, 0); } } @@ -2003,8 +2004,8 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Objec existing rename. */ if (!SCHEME_HASHTP((Scheme_Object *)env) && env->module && (mode < 2)) { Scheme_Object *mod, *nm = id; - mod = scheme_stx_module_name(0, &nm, scheme_make_integer(env->phase), NULL, NULL, NULL, - NULL, NULL, NULL, NULL); + mod = scheme_stx_module_name(NULL, &nm, scheme_make_integer(env->phase), NULL, NULL, NULL, + NULL, NULL, NULL, NULL, NULL); if (mod /* must refer to env->module, otherwise there would have been an error before getting here */ && NOT_SAME_OBJ(nm, sym)) @@ -2527,7 +2528,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, int j = 0, p = 0, modpos, skip_stops = 0, module_self_reference = 0; Scheme_Bucket *b; Scheme_Object *val, *modidx, *modname, *src_find_id, *find_global_id, *mod_defn_phase; - Scheme_Object *find_id_sym = NULL; + Scheme_Object *find_id_sym = NULL, *rename_insp = NULL; Scheme_Env *genv; long phase; @@ -2679,8 +2680,8 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, } src_find_id = find_id; - modidx = scheme_stx_module_name(0, &find_id, scheme_make_integer(phase), NULL, NULL, &mod_defn_phase, - NULL, NULL, NULL, NULL); + modidx = scheme_stx_module_name(NULL, &find_id, scheme_make_integer(phase), NULL, NULL, &mod_defn_phase, + NULL, NULL, NULL, NULL, &rename_insp); /* Used out of context? */ if (SAME_OBJ(modidx, scheme_undefined)) { @@ -2765,9 +2766,10 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, val = scheme_module_syntax(modname, env->genv, find_id); if (val && !(flags & SCHEME_NO_CERT_CHECKS)) scheme_check_accessible_in_module(genv, env->insp, in_modidx, - find_id, src_find_id, certs, NULL, -2, 0, - NULL, - env->genv); + find_id, src_find_id, certs, NULL, rename_insp, + -2, 0, + NULL, NULL, + env->genv, NULL); } else { /* Only try syntax table if there's not an explicit (later) variable mapping: */ @@ -2790,8 +2792,8 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, pos = 0; else pos = scheme_check_accessible_in_module(genv, env->insp, in_modidx, - find_id, src_find_id, certs, NULL, -1, 1, - _protected, env->genv); + find_id, src_find_id, certs, NULL, rename_insp, -1, 1, + _protected, NULL, env->genv, NULL); modpos = SCHEME_INT_VAL(pos); } else modpos = -1; @@ -2957,8 +2959,8 @@ int scheme_check_context(Scheme_Env *env, Scheme_Object *name, Scheme_Object *ok if (mod && SCHEME_TRUEP(mod) && NOT_SAME_OBJ(ok_modidx, mod)) { return 1; } else { - mod = scheme_stx_module_name(0, &id, scheme_make_integer(env->phase), NULL, NULL, NULL, - NULL, NULL, NULL, NULL); + mod = scheme_stx_module_name(NULL, &id, scheme_make_integer(env->phase), NULL, NULL, NULL, + NULL, NULL, NULL, NULL, NULL); if (SAME_OBJ(mod, scheme_undefined)) return 1; } diff --git a/src/mzscheme/src/error.c b/src/mzscheme/src/error.c index 1450a85917..ce5b889df5 100644 --- a/src/mzscheme/src/error.c +++ b/src/mzscheme/src/error.c @@ -191,6 +191,7 @@ Scheme_Config *scheme_init_error_escape_proc(Scheme_Config *config) %Q = truncated-to-256 Scheme string %V = scheme_value %D = scheme value to display + %_ = skip %L = line number, -1 means no line %e = error number for strerror() @@ -258,6 +259,7 @@ static long sch_vsprintf(char *s, long maxlen, const char *msg, va_list args, ch case 'D': case 'T': case 'Q': + case '_': ptrs[pp++] = mzVA_ARG(args, Scheme_Object*); break; default: @@ -446,6 +448,13 @@ static long sch_vsprintf(char *s, long maxlen, const char *msg, va_list args, ch tlen = dlen; } break; + case '_': + { + pp++; + t = ""; + tlen = 0; + } + break; case 'T': case 'Q': { @@ -1601,7 +1610,7 @@ static void do_wrong_syntax(const char *where, phase = scheme_current_thread->current_local_env->genv->phase; else phase = 0; scheme_stx_module_name(0, &first, scheme_make_integer(phase), &mod, &nomwho, - NULL, NULL, NULL, NULL, NULL); + NULL, NULL, NULL, NULL, NULL, NULL); } } } else { @@ -1904,7 +1913,7 @@ void scheme_unbound_global(Scheme_Bucket *b) if (SCHEME_TRUEP(scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_SRCLOC))) errmsg = "reference to an identifier before its definition: %S in module: %D%s"; else - errmsg = "reference to an identifier before its definition: %S%s"; + errmsg = "reference to an identifier before its definition: %S%_%s"; if (SCHEME_INT_VAL(((Scheme_Bucket_With_Home *)b)->home->phase)) { sprintf(phase_buf, " phase: %ld", SCHEME_INT_VAL(((Scheme_Bucket_With_Home *)b)->home->phase)); diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index d007463d37..3552cff5e0 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -1788,7 +1788,7 @@ static Scheme_Object *link_module_variable(Scheme_Object *modidx, if (check_access && !SAME_OBJ(menv, env)) { varname = scheme_check_accessible_in_module(menv, insp, NULL, varname, NULL, NULL, - insp, pos, 0, NULL, env); + insp, NULL, pos, 0, NULL, NULL, env, NULL); } } @@ -6090,8 +6090,8 @@ static Scheme_Object *check_top(const char *when, Scheme_Object *form, Scheme_Co if (NOT_SAME_OBJ(tl_id, SCHEME_STX_SYM(symbol))) { /* Since the module has a rename for this id, it's certainly defined. */ } else { - modidx = scheme_stx_module_name(0, &symbol, scheme_make_integer(env->genv->phase), NULL, NULL, NULL, - NULL, NULL, NULL, NULL); + modidx = scheme_stx_module_name(NULL, &symbol, scheme_make_integer(env->genv->phase), NULL, NULL, NULL, + NULL, NULL, NULL, NULL, NULL); if (modidx) { /* If it's an access path, resolve it: */ if (env->genv->module diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index 700c6f4af9..31f70fe9a9 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -142,6 +142,7 @@ static void *stack_cache_pop_code; static void *struct_pred_code, *struct_pred_multi_code; static void *struct_pred_branch_code; static void *struct_get_code, *struct_get_multi_code; +static void *struct_set_code, *struct_set_multi_code; static void *bad_app_vals_target; static void *app_values_slow_code, *app_values_multi_slow_code, *app_values_tail_slow_code; static void *finish_tail_call_code, *finish_tail_call_fixup_code; @@ -169,7 +170,9 @@ typedef struct { int local1_busy; int log_depth; int self_pos, self_closure_size, self_toplevel_pos; - int self_to_closure_delta; + int self_to_closure_delta, closure_to_args_delta; + int example_argc; + Scheme_Object **example_argv; void *self_restart_code; void *self_nontail_code; Scheme_Native_Closure *nc; /* for extract_globals and extract_closure_local, only */ @@ -201,6 +204,9 @@ static void generate_non_tail_mark_pos_suffix(mz_jit_state *jitter); static void *generate_shared_call(int num_rands, mz_jit_state *old_jitter, int multi_ok, int is_tail, int direct_prim, int direct_native, int nontail_self); +static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_state *jitter, + int order_matters, int skipped); + static int is_simple(Scheme_Object *obj, int depth, int just_markless, mz_jit_state *jitter, int stack_start); static int lambda_has_been_jitted(Scheme_Native_Closure_Data *ndata); @@ -1485,38 +1491,51 @@ Scheme_Object *extract_closure_local(Scheme_Object *obj, mz_jit_state *jitter, i if (pos >= jitter->self_pos - jitter->self_to_closure_delta) { pos -= (jitter->self_pos - jitter->self_to_closure_delta); if (pos < jitter->nc->code->u2.orig_code->closure_size) { + /* in the closure */ return jitter->nc->vals[pos]; + } else { + /* maybe an example argument... which is useful when + the enclosing function has been lifted, converting + a closure element into an argument */ + pos -= jitter->closure_to_args_delta; + if (pos < jitter->example_argc) + return jitter->example_argv[pos]; } } return NULL; } -static int check_val_struct_prim(Scheme_Object *p) +static int check_val_struct_prim(Scheme_Object *p, int arity) { if (p && SCHEME_PRIMP(p)) { - if (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_PRED) - return 1; - else if (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER) - return 2; - else - return 0; - } else - return 0; + if (arity == 1) { + if (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_PRED) + return 1; + else if (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER) + return 2; + } else if (arity == 2) { + if ((((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_OTHER) + && ((((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_STRUCT_OTHER_TYPE_MASK) + == SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER)) + return 3; + } + } + return 0; } -static int inlineable_struct_prim(Scheme_Object *o, mz_jit_state *jitter, int extra_push) +static int inlineable_struct_prim(Scheme_Object *o, mz_jit_state *jitter, int extra_push, int arity) { if (jitter->nc) { if (SAME_TYPE(SCHEME_TYPE(o), scheme_toplevel_type)) { Scheme_Object *p; p = extract_global(o, jitter->nc); p = ((Scheme_Bucket *)p)->val; - return check_val_struct_prim(p); + return check_val_struct_prim(p, arity); } else if (SAME_TYPE(SCHEME_TYPE(o), scheme_local_type)) { Scheme_Object *p; p = extract_closure_local(o, jitter, extra_push); - return check_val_struct_prim(p); + return check_val_struct_prim(p, arity); } } return 0; @@ -1528,23 +1547,24 @@ static int inlined_unary_prim(Scheme_Object *o, Scheme_Object *_app, mz_jit_stat && (SCHEME_PRIM_PROC_FLAGS(o) & SCHEME_PRIM_IS_UNARY_INLINED)) return 1; - if (inlineable_struct_prim(o, jitter, 1)) + if (inlineable_struct_prim(o, jitter, 1, 1)) return 1; return 0; } -static int inlined_binary_prim(Scheme_Object *o, Scheme_Object *_app) +static int inlined_binary_prim(Scheme_Object *o, Scheme_Object *_app, mz_jit_state *jitter) { - return (SCHEME_PRIMP(o) - && (SCHEME_PRIM_PROC_FLAGS(o) & SCHEME_PRIM_IS_BINARY_INLINED)); + return ((SCHEME_PRIMP(o) + && (SCHEME_PRIM_PROC_FLAGS(o) & SCHEME_PRIM_IS_BINARY_INLINED)) + || inlineable_struct_prim(o, jitter, 2, 2)); } static int inlined_nary_prim(Scheme_Object *o, Scheme_Object *_app) { return (SCHEME_PRIMP(o) - && (SCHEME_PRIM_PROC_FLAGS(o) & SCHEME_PRIM_IS_NARY_INLINED) - && (((Scheme_App_Rec *)_app)->num_args >= ((Scheme_Primitive_Proc *)o)->mina) + && (SCHEME_PRIM_PROC_FLAGS(o) & SCHEME_PRIM_IS_NARY_INLINED) + && (((Scheme_App_Rec *)_app)->num_args >= ((Scheme_Primitive_Proc *)o)->mina) && (((Scheme_App_Rec *)_app)->num_args <= ((Scheme_Primitive_Proc *)o)->mu.maxa)); } @@ -1670,7 +1690,7 @@ static int is_simple(Scheme_Object *obj, int depth, int just_markless, mz_jit_st } break; case scheme_application3_type: - if (inlined_binary_prim(((Scheme_App2_Rec *)obj)->rator, obj)) + if (inlined_binary_prim(((Scheme_App2_Rec *)obj)->rator, obj, jitter)) return 1; else if (just_markless) { return is_noncm(((Scheme_App3_Rec *)obj)->rator, jitter, depth, stack_start + 2); @@ -2603,7 +2623,9 @@ static int can_direct_native(Scheme_Object *p, int num_rands, long *extract_case static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_rands, mz_jit_state *jitter, int is_tail, int multi_ok, int no_call) -/* de-sync'd ok */ +/* de-sync'd ok + If no_call is 2, then rator is not necssarily evaluated. + If no_call is 1, then rator is left in V1 and arguments are on runstack. */ { int i, offset, need_safety = 0; int direct_prim = 0, need_non_tail = 0, direct_native = 0, direct_self = 0, nontail_self = 0; @@ -2840,13 +2862,14 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ } if (reorder_ok) { - if (!no_call) { - generate(rator, jitter, 0, 0, JIT_V1); /* sync'd below */ + if (no_call < 2) { + generate(rator, jitter, 0, 0, JIT_V1); /* sync'd below, or not */ } CHECK_LIMIT(); } - mz_rs_sync(); + if (!no_call) + mz_rs_sync(); END_JIT_DATA(20); @@ -3893,42 +3916,33 @@ static int generate_inlined_type_test(mz_jit_state *jitter, Scheme_App2_Rec *app } static int generate_inlined_struct_op(int kind, mz_jit_state *jitter, - Scheme_Object *rator, Scheme_Object *rand, + Scheme_Object *rator, Scheme_Object *rand, Scheme_Object *rand2, jit_insn **for_branch, int branch_short, int multi_ok) /* de-sync'd ok; for branch, sync'd before */ { - mz_runstack_skipped(jitter, 1); - LOG_IT(("inlined struct op\n")); - generate(rator, jitter, 0, 0, JIT_R0); /* sync'd below */ - CHECK_LIMIT(); - - if (SAME_TYPE(scheme_local_type, SCHEME_TYPE(rand))) { - jit_movr_p(JIT_R1, JIT_R0); - generate(rand, jitter, 0, 0, JIT_R0); /* sync'd below */ - mz_runstack_unskipped(jitter, 1); + if (!rand2) { + generate_two_args(rator, rand, jitter, 1, 1); /* sync'd below */ + CHECK_LIMIT(); } else { - mz_runstack_unskipped(jitter, 1); - - mz_rs_dec(1); - CHECK_RUNSTACK_OVERFLOW(); - mz_runstack_pushed(jitter, 1); - mz_rs_str(JIT_R0); + Scheme_Object *args[3]; + args[0] = rator; + args[1] = rand; + args[2] = rand2; + generate_app(NULL, args, 2, jitter, 0, 0, 1); /* sync'd below */ CHECK_LIMIT(); - - generate_non_tail(rand, jitter, 0, 1); /* sync'd below */ - CHECK_LIMIT(); - + jit_movr_p(JIT_R0, JIT_V1); mz_rs_ldr(JIT_R1); - mz_rs_inc(1); - mz_runstack_popped(jitter, 1); + mz_rs_ldxi(JIT_V1, 1); + mz_rs_inc(2); /* sync'd below */ + mz_runstack_popped(jitter, 2); } - mz_rs_sync(); - /* R1 is [potential] predicate/getter, R0 is value */ + /* R0 is [potential] predicate/getter/setting, R1 is struct. + V1 is value for setting. */ if (for_branch) { for_branch[2] = jit_patchable_movi_p(JIT_V1, jit_forward()); @@ -3939,12 +3953,18 @@ static int generate_inlined_struct_op(int kind, mz_jit_state *jitter, } else { (void)jit_calli(struct_pred_code); } - } else { + } else if (kind == 2) { if (multi_ok) { (void)jit_calli(struct_get_multi_code); } else { (void)jit_calli(struct_get_code); } + } else { + if (multi_ok) { + (void)jit_calli(struct_set_multi_code); + } else { + (void)jit_calli(struct_set_code); + } } return 1; @@ -3962,13 +3982,13 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in { int k; - k = inlineable_struct_prim(rator, jitter, 1); + k = inlineable_struct_prim(rator, jitter, 1, 1); if (k == 1) { - generate_inlined_struct_op(1, jitter, rator, app->rand, for_branch, branch_short, multi_ok); + generate_inlined_struct_op(1, jitter, rator, app->rand, NULL, for_branch, branch_short, multi_ok); scheme_direct_call_count++; return 1; } else if ((k == 2) && !for_branch) { - generate_inlined_struct_op(2, jitter, rator, app->rand, for_branch, branch_short, multi_ok); + generate_inlined_struct_op(2, jitter, rator, app->rand, NULL, for_branch, branch_short, multi_ok); scheme_direct_call_count++; return 1; } @@ -4377,7 +4397,8 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in return 0; } -static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_state *jitter, int order_matters) +static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_state *jitter, + int order_matters, int skipped) /* de-sync's rs. Results go into R0 and R1. If !order_matters, and if only the second is simple, then the arguments will be in reverse order. */ @@ -4389,7 +4410,7 @@ static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_ if (!simple1) { if (simple2) { - mz_runstack_skipped(jitter, 2); + mz_runstack_skipped(jitter, skipped); generate_non_tail(rand1, jitter, 0, 1); /* no sync... */ CHECK_LIMIT(); @@ -4406,18 +4427,18 @@ static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_ } else direction = -1; - mz_runstack_unskipped(jitter, 2); + mz_runstack_unskipped(jitter, skipped); } else { - mz_runstack_skipped(jitter, 2); + mz_runstack_skipped(jitter, skipped); generate_non_tail(rand1, jitter, 0, 1); /* no sync... */ CHECK_LIMIT(); - mz_runstack_unskipped(jitter, 2); + mz_runstack_unskipped(jitter, skipped); mz_rs_dec(1); CHECK_RUNSTACK_OVERFLOW(); mz_runstack_pushed(jitter, 1); mz_rs_str(JIT_R0); - mz_runstack_skipped(jitter, 1); + mz_runstack_skipped(jitter, skipped-1); generate_non_tail(rand2, jitter, 0, 1); /* no sync... */ CHECK_LIMIT(); @@ -4425,12 +4446,12 @@ static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_ jit_movr_p(JIT_R1, JIT_R0); mz_rs_ldr(JIT_R0); - mz_runstack_unskipped(jitter, 1); + mz_runstack_unskipped(jitter, skipped-1); mz_rs_inc(1); mz_runstack_popped(jitter, 1); } } else { - mz_runstack_skipped(jitter, 2); + mz_runstack_skipped(jitter, skipped); if (simple2) { generate(rand2, jitter, 0, 0, JIT_R1); /* no sync... */ @@ -4444,7 +4465,7 @@ static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_ generate(rand1, jitter, 0, 0, JIT_R0); /* no sync... */ CHECK_LIMIT(); - mz_runstack_unskipped(jitter, 2); + mz_runstack_unskipped(jitter, skipped); } return direction; @@ -4462,7 +4483,7 @@ static int generate_binary_char(mz_jit_state *jitter, Scheme_App3_Rec *app, r1 = app->rand1; r2 = app->rand2; - direction = generate_two_args(r1, r2, jitter, 1); + direction = generate_two_args(r1, r2, jitter, 1, 2); CHECK_LIMIT(); mz_rs_sync(); @@ -4604,6 +4625,14 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i { Scheme_Object *rator = app->rator; + if (!for_branch + && inlineable_struct_prim(rator, jitter, 2, 2)) { + generate_inlined_struct_op(3, jitter, rator, app->rand1, app->rand2, for_branch, branch_short, multi_ok); + scheme_direct_call_count++; + return 1; + } + + if (!SCHEME_PRIMP(rator)) return 0; @@ -4669,7 +4698,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i __END_SHORT_JUMPS__(branch_short); } else { /* Two complex expressions: */ - generate_two_args(a2, a1, jitter, 0); + generate_two_args(a2, a1, jitter, 0, 2); CHECK_LIMIT(); mz_rs_sync(); @@ -4762,7 +4791,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i && (SCHEME_INT_VAL(app->rand2) >= 0)); if (!simple) { - generate_two_args(app->rand1, app->rand2, jitter, 1); + generate_two_args(app->rand1, app->rand2, jitter, 1, 2); CHECK_LIMIT(); mz_rs_sync(); @@ -4816,7 +4845,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i LOG_IT(("inlined set-mcar!\n")); - generate_two_args(app->rand1, app->rand2, jitter, 1); + generate_two_args(app->rand1, app->rand2, jitter, 1, 2); CHECK_LIMIT(); mz_rs_sync(); @@ -4847,7 +4876,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i || IS_NAMED_PRIM(rator, "list*")) { LOG_IT(("inlined cons\n")); - generate_two_args(app->rand1, app->rand2, jitter, 1); + generate_two_args(app->rand1, app->rand2, jitter, 1, 2); CHECK_LIMIT(); mz_rs_sync(); @@ -4855,7 +4884,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i } else if (IS_NAMED_PRIM(rator, "mcons")) { LOG_IT(("inlined mcons\n")); - generate_two_args(app->rand1, app->rand2, jitter, 1); + generate_two_args(app->rand1, app->rand2, jitter, 1, 2); CHECK_LIMIT(); mz_rs_sync(); @@ -4881,7 +4910,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i } else if (IS_NAMED_PRIM(rator, "list")) { LOG_IT(("inlined list\n")); - generate_two_args(app->rand1, app->rand2, jitter, 1); + generate_two_args(app->rand1, app->rand2, jitter, 1, 2); CHECK_LIMIT(); mz_rs_dec(1); @@ -5054,7 +5083,7 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int star = IS_NAMED_PRIM(rator, "list*"); if (c) - generate_app(app, NULL, c, jitter, 0, 0, 1); + generate_app(app, NULL, c, jitter, 0, 0, 2); CHECK_LIMIT(); mz_rs_sync(); @@ -5145,12 +5174,12 @@ static int generate_vector_alloc(mz_jit_state *jitter, Scheme_Object *rator, mz_runstack_unskipped(jitter, 1); c = 1; } else if (app3) { - generate_two_args(app3->rand1, app3->rand2, jitter, 1); /* sync'd below */ + generate_two_args(app3->rand1, app3->rand2, jitter, 1, 2); /* sync'd below */ c = 2; } else { c = app->num_args; if (c) - generate_app(app, NULL, c, jitter, 0, 0, 1); /* sync'd below */ + generate_app(app, NULL, c, jitter, 0, 0, 2); /* sync'd below */ } CHECK_LIMIT(); @@ -6652,6 +6681,36 @@ static int generate_function_getarg(mz_jit_state *jitter, int has_rest, int num_ return cnt; } +static int save_struct_temp(mz_jit_state *jitter) +{ +#ifdef MZ_USE_JIT_PPC + jit_movr_p(JIT_V(3), JIT_V1); +#endif +#ifdef MZ_USE_JIT_I386 +# ifdef X86_ALIGN_STACK + mz_set_local_p(JIT_V1, JIT_LOCAL3); +# else + jit_pushr_p(JIT_V1); +# endif +#endif + return 1; +} + +static int restore_struct_temp(mz_jit_state *jitter, int reg) +{ +#ifdef MZ_USE_JIT_PPC + jit_movr_p(reg, JIT_V(3)); +#endif +#ifdef MZ_USE_JIT_I386 +# ifdef X86_ALIGN_STACK + mz_get_local_p(reg, JIT_LOCAL3); +# else + jit_popr_p(reg); +# endif +#endif + return 1; +} + static int do_generate_common(mz_jit_state *jitter, void *_data) { int in, i, ii, iii; @@ -7399,11 +7458,12 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) __END_TINY_JUMPS__(1); } - /* *** struct_{pred,get}[_branch]_code *** */ - /* R1 is (potential) struct proc, R0 is (potential) struct */ - /* In branch mode, V1 is target address for false branch */ + /* *** struct_{pred,get,set}[_branch]_code *** */ + /* R0 is (potential) struct proc, R1 is (potential) struct. */ + /* In branch mode, V1 is target address for false branch. */ + /* In set mode, V1 is value to install. */ for (ii = 0; ii < 2; ii++) { - for (i = 0; i < 3; i++) { + for (i = 0; i < 4; i++) { void *code, *code_end; int kind, for_branch; jit_insn *ref, *ref2, *refslow, *bref1, *bref2, *bref3, *bref4, *bref5, *bref6, *bref8; @@ -7424,44 +7484,48 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) for_branch = 1; struct_pred_branch_code = jit_get_ip().ptr; /* Save target address for false branch: */ -#ifdef MZ_USE_JIT_PPC - jit_movr_p(JIT_V(3), JIT_V1); -#endif -#ifdef MZ_USE_JIT_I386 -# ifdef X86_ALIGN_STACK - mz_set_local_p(JIT_V1, JIT_LOCAL3); -# else - jit_pushr_p(JIT_V1); -# endif -#endif - } else { + save_struct_temp(jitter); + } else if (i == 2) { kind = 2; for_branch = 0; if (ii == 1) struct_get_multi_code = jit_get_ip().ptr; else struct_get_code = jit_get_ip().ptr; + } else { + kind = 3; + for_branch = 0; + if (ii == 1) + struct_set_multi_code = jit_get_ip().ptr; + else + struct_set_code = jit_get_ip().ptr; + /* Save value to install: */ + save_struct_temp(jitter); } mz_prolog(JIT_V1); __START_SHORT_JUMPS__(1); - ref = jit_bmci_ul(jit_forward(), JIT_R1, 0x1); + ref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1); CHECK_LIMIT(); /* Slow path: non-struct proc, or argument type is bad for a getter. */ refslow = _jit.x.pc; - jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); + jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES((kind == 3) ? 2 : 1)); CHECK_RUNSTACK_OVERFLOW(); JIT_UPDATE_THREAD_RSPTR(); - jit_str_p(JIT_RUNSTACK, JIT_R0); - jit_movi_i(JIT_V1, 1); + jit_str_p(JIT_RUNSTACK, JIT_R1); + if (kind == 3) { + restore_struct_temp(jitter, JIT_V1); + jit_stxi_p(WORDS_TO_BYTES(1), JIT_RUNSTACK, JIT_V1); + } + jit_movi_i(JIT_V1, ((kind == 3) ? 2 : 1)); jit_prepare(3); jit_pusharg_p(JIT_RUNSTACK); jit_pusharg_p(JIT_V1); - jit_pusharg_p(JIT_R1); + jit_pusharg_p(JIT_R0); if (ii == 1) { (void)mz_finish(_scheme_apply_multi_from_native); } else { @@ -7469,7 +7533,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) } jit_retval(JIT_R0); VALIDATE_RESULT(JIT_R0); - jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); + jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES((kind == 3) ? 2 : 1)); JIT_UPDATE_THREAD_RSPTR(); if (!for_branch) { mz_epilog(JIT_V1); @@ -7484,24 +7548,29 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) /* Continue trying fast path: check proc */ mz_patch_branch(ref); - jit_ldxi_s(JIT_R2, JIT_R1, &((Scheme_Object *)0x0)->type); + jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type); (void)jit_bnei_i(refslow, JIT_R2, scheme_prim_type); - jit_ldxi_s(JIT_R2, JIT_R1, &((Scheme_Primitive_Proc *)0x0)->pp.flags); - (void)jit_bmci_i(refslow, JIT_R2, ((kind == 1) - ? SCHEME_PRIM_IS_STRUCT_PRED - : SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER)); + jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Primitive_Proc *)0x0)->pp.flags); + if (kind == 3) { + jit_andi_i(JIT_R2, JIT_R2, SCHEME_PRIM_STRUCT_OTHER_TYPE_MASK); + (void)jit_bnei_i(refslow, JIT_R2, SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER); + } else { + (void)jit_bmci_i(refslow, JIT_R2, ((kind == 1) + ? SCHEME_PRIM_IS_STRUCT_PRED + : SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER)); + } CHECK_LIMIT(); /* Check argument: */ if (kind == 1) { - bref1 = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1); - jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type); + bref1 = jit_bmsi_ul(jit_forward(), JIT_R1, 0x1); + jit_ldxi_s(JIT_R2, JIT_R1, &((Scheme_Object *)0x0)->type); __START_INNER_TINY__(1); ref2 = jit_beqi_i(jit_forward(), JIT_R2, scheme_structure_type); __END_INNER_TINY__(1); bref2 = jit_bnei_i(jit_forward(), JIT_R2, scheme_proc_struct_type); } else { - (void)jit_bmsi_ul(refslow, JIT_R0, 0x1); - jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type); + (void)jit_bmsi_ul(refslow, JIT_R1, 0x1); + jit_ldxi_s(JIT_R2, JIT_R1, &((Scheme_Object *)0x0)->type); __START_INNER_TINY__(1); ref2 = jit_beqi_i(jit_forward(), JIT_R2, scheme_structure_type); __END_INNER_TINY__(1); @@ -7514,15 +7583,15 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) CHECK_LIMIT(); /* Put argument struct type in R2, target struct type in V1 */ - jit_ldxi_p(JIT_R2, JIT_R0, &((Scheme_Structure *)0x0)->stype); - jit_ldxi_p(JIT_V1, JIT_R1, &((Scheme_Primitive_Closure *)0x0)->val); - if (kind == 2) { + jit_ldxi_p(JIT_R2, JIT_R1, &((Scheme_Structure *)0x0)->stype); + jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val); + if (kind >= 2) { jit_ldxi_p(JIT_V1, JIT_V1, &((Struct_Proc_Info *)0x0)->struct_type); } CHECK_LIMIT(); /* common case: types are the same */ - if (kind == 2) { + if (kind >= 2) { __START_INNER_TINY__(1); bref8 = jit_beqr_p(jit_forward(), JIT_R2, JIT_V1); __END_INNER_TINY__(1); @@ -7542,13 +7611,13 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) /* Lookup argument type at target type depth, put it in R2: */ jit_lshi_ul(JIT_R2, JIT_V1, JIT_LOG_WORD_SIZE); jit_addi_p(JIT_R2, JIT_R2, &((Scheme_Struct_Type *)0x0)->parent_types); - jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Structure *)0x0)->stype); + jit_ldxi_p(JIT_V1, JIT_R1, &((Scheme_Structure *)0x0)->stype); jit_ldxr_p(JIT_R2, JIT_V1, JIT_R2); CHECK_LIMIT(); /* Re-load target type into V1: */ - jit_ldxi_p(JIT_V1, JIT_R1, &((Scheme_Primitive_Closure *)0x0)->val); - if (kind == 2) { + jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val); + if (kind >= 2) { jit_ldxi_p(JIT_V1, JIT_V1, &((Struct_Proc_Info *)0x0)->struct_type); } @@ -7575,16 +7644,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) mz_patch_branch(bref4); if (for_branch) { mz_patch_branch(bref5); -#ifdef MZ_USE_JIT_PPC - jit_movr_p(JIT_V1, JIT_V(3)); -#endif -#ifdef MZ_USE_JIT_I386 -# ifdef X86_ALIGN_STACK - mz_get_local_p(JIT_V1, JIT_LOCAL3); -# else - jit_popr_p(JIT_V1); -# endif -#endif + restore_struct_temp(jitter, JIT_V1); mz_epilog_without_jmp(); jit_jmpr(JIT_V1); } else { @@ -7598,11 +7658,17 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) mz_patch_branch(bref8); __END_INNER_TINY__(1); /* Extract field */ - jit_ldxi_p(JIT_V1, JIT_R1, &((Scheme_Primitive_Closure *)0x0)->val); + jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val); jit_ldxi_i(JIT_V1, JIT_V1, &((Struct_Proc_Info *)0x0)->field); jit_lshi_ul(JIT_V1, JIT_V1, JIT_LOG_WORD_SIZE); jit_addi_p(JIT_V1, JIT_V1, &((Scheme_Structure *)0x0)->slots); - jit_ldxr_p(JIT_R0, JIT_R0, JIT_V1); + if (kind == 3) { + restore_struct_temp(jitter, JIT_R0); + jit_stxr_p(JIT_V1, JIT_R1, JIT_R0); + (void)jit_movi_p(JIT_R0, scheme_void); + } else { + jit_ldxr_p(JIT_R0, JIT_R1, JIT_V1); + } mz_epilog(JIT_V1); } CHECK_LIMIT(); @@ -7718,6 +7784,8 @@ typedef struct { void *arity_code, *code, *tail_code, *code_end, **patch_depth; int max_extra, max_depth; Scheme_Native_Closure *nc; + int argc; + Scheme_Object **argv; } Generate_Closure_Data; static int do_generate_closure(mz_jit_state *jitter, void *_data) @@ -7725,12 +7793,16 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data) Generate_Closure_Data *gdata = (Generate_Closure_Data *)_data; Scheme_Closure_Data *data = gdata->data; void *code, *tail_code, *code_end, *arity_code; - int i, r, cnt, has_rest, is_method, num_params; + int i, r, cnt, has_rest, is_method, num_params, to_args, argc; + Scheme_Object **argv; code = jit_get_ip().ptr; jitter->nc = gdata->nc; + argc = gdata->argc; + argv = gdata->argv; + generate_function_prolog(jitter, code, /* max_extra_pushed may be wrong the first time around, but it will be right the last time around */ @@ -7836,18 +7908,31 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data) __END_SHORT_JUMPS__(cnt < 100); has_rest = 1; - } else + if (argc < (data->num_params - 1)) { + argv = NULL; + argc = 0; + } + } else { has_rest = 0; + if (argc != data->num_params) { + argv = NULL; + argc = 0; + } + } #ifdef JIT_PRECISE_GC /* Keeping the native-closure pointer on the runstack ensures that the code won't be GCed while we're running it. */ mz_pushr_p(JIT_R0); /* no sync */ + to_args = 0; +#else + to_args = 0; #endif /* Extract closure to runstack: */ cnt = data->closure_size; + to_args += cnt; if (cnt) { mz_rs_dec(cnt); CHECK_RUNSTACK_OVERFLOW(); @@ -7915,6 +8000,9 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data) jitter->self_nontail_code = tail_code; jitter->self_to_closure_delta = jitter->self_pos; + jitter->closure_to_args_delta = to_args; + jitter->example_argc = argc; + jitter->example_argv = argv; /* Generate code for the body: */ jitter->need_set_rs = 1; @@ -7945,7 +8033,7 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data) return 1; } -static void on_demand_generate_lambda(Scheme_Native_Closure *nc) +static void on_demand_generate_lambda(Scheme_Native_Closure *nc, int argc, Scheme_Object **argv) { Scheme_Native_Closure_Data *ndata = nc->code; Scheme_Closure_Data *data; @@ -7957,6 +8045,8 @@ static void on_demand_generate_lambda(Scheme_Native_Closure *nc) gdata.data = data; gdata.nc = nc; + gdata.argc = argc; + gdata.argv = argv; scheme_delay_load_closure(data); @@ -8024,7 +8114,7 @@ static void on_demand() argc = MZ_RUNSTACK[1]; argv = (Scheme_Object **)MZ_RUNSTACK[2]; - on_demand_generate_lambda((Scheme_Native_Closure *)c); + on_demand_generate_lambda((Scheme_Native_Closure *)c, SCHEME_INT_VAL(argc), argv); } Scheme_Native_Closure_Data *scheme_generate_lambda(Scheme_Closure_Data *data, int clear_code_after_jit, diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index 09d108b91b..b0c90a7843 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -217,7 +217,7 @@ typedef void (*Check_Func)(Scheme_Object *prnt_name, Scheme_Object *name, int isval, void *data, Scheme_Object *e, Scheme_Object *form, Scheme_Object *err_src, Scheme_Object *mark_src, Scheme_Object *to_phase, Scheme_Object *src_phase_index, - Scheme_Object *nominal_export_phase); + Scheme_Object *nominal_export_phase, Scheme_Object *in_insp); static void parse_requires(Scheme_Object *form, Scheme_Object *base_modidx, Scheme_Env *env, @@ -245,13 +245,11 @@ static int compute_reprovides(Scheme_Hash_Table *all_provided, Scheme_Env *genv, Scheme_Object *all_rt_defs, Scheme_Object *all_rt_defs_out, Scheme_Object *all_et_defs, Scheme_Object *all_et_defs_out, - Scheme_Object **_exclude_hint, const char *matching_form, Scheme_Object *all_mods, Scheme_Object *all_phases); static char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table *tables, Scheme_Module_Exports *me, Scheme_Env *genv, - int reprovide_kernel, Scheme_Object *form, char **_phase1_protects); static Scheme_Object **compute_indirects(Scheme_Env *genv, @@ -268,7 +266,7 @@ static Scheme_Object *do_namespace_require(Scheme_Env *env, int argc, Scheme_Obj static Scheme_Object *default_module_resolver(int argc, Scheme_Object **argv); static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Object **exss, char *exps, char *exets, - Scheme_Object **exsnoms, + Scheme_Object **exsnoms, Scheme_Object **exinsps, int start, int count, int do_uninterned); #define MODCHAIN_TABLE(p) ((Scheme_Hash_Table *)(SCHEME_VEC_ELS(p)[0])) @@ -479,7 +477,7 @@ void scheme_finish_kernel(Scheme_Env *env) rn = scheme_make_module_rename(scheme_make_integer(0), mzMOD_RENAME_NORMAL, NULL); for (i = kernel->me->rt->num_provides; i--; ) { scheme_extend_module_rename(rn, kernel_modidx, exs[i], exs[i], kernel_modidx, exs[i], - 0, scheme_make_integer(0), NULL, 0); + 0, scheme_make_integer(0), NULL, NULL, 0); } scheme_seal_module_rename(rn, STX_SEAL_ALL); @@ -613,8 +611,13 @@ Scheme_Object *scheme_sys_wraps_phase(Scheme_Object *phase) rn = scheme_make_module_rename(phase, mzMOD_RENAME_NORMAL, NULL); /* Add a module mapping for all kernel provides: */ - scheme_extend_module_rename_with_kernel(rn, kernel_modidx); - + scheme_extend_module_rename_with_shared(rn, kernel_modidx, + kernel->me->rt, + scheme_make_integer(p), + scheme_make_integer(0), + scheme_null, + 1); + scheme_seal_module_rename(rn, STX_SEAL_ALL); w = scheme_datum_to_syntax(kernel_symbol, scheme_false, scheme_false, 0, 0); @@ -863,8 +866,6 @@ static Scheme_Object *_dynamic_require(int argc, Scheme_Object *argv[], srcname = name; srcmname = modname; } else { - try_again: - /* Before starting, check whether the name is provided */ count = srcm->me->rt->num_provides; if (position >= 0) { @@ -930,12 +931,6 @@ static Scheme_Object *_dynamic_require(int argc, Scheme_Object *argv[], srcname = srcm->me->rt->provide_src_names[i]; } - if ((position < 0) && (i == count) && srcm->me->rt->reprovide_kernel) { - /* Check kernel. */ - srcm = kernel; - goto try_again; - } - if (i == count) { if (indirect_ok) { /* Try indirect provides: */ @@ -2180,13 +2175,13 @@ static int do_add_simple_require_renames(Scheme_Object *rn, int can_override) { int i, saw_mb, numvals; - Scheme_Object **exs, **exss, **exsns, *midx, *info, *vec, *nml, *mark_src; + Scheme_Object **exs, **exss, **exsns, *midx, *info, *vec, *nml, *mark_src, **exinsps; char *exets; int with_shared = 1; saw_mb = 0; - if (!pt->num_provides && !pt->reprovide_kernel) + if (!pt->num_provides) return 0; if (with_shared) { @@ -2205,6 +2200,7 @@ static int do_add_simple_require_renames(Scheme_Object *rn, exsns = pt->provide_src_names; exss = pt->provide_srcs; exets = pt->provide_src_phases; + exinsps = pt->provide_insps; numvals = pt->num_var_provides; for (i = pt->num_provides; i--; ) { if (exss && !SCHEME_FALSEP(exss[i])) @@ -2213,13 +2209,14 @@ static int do_add_simple_require_renames(Scheme_Object *rn, midx = idx; if (!with_shared) { scheme_extend_module_rename(rn, midx, exs[i], exsns[i], idx, exs[i], - exets ? exets[i] : 0, src_phase_index, pt->phase_index, 1); + exets ? exets[i] : 0, src_phase_index, pt->phase_index, + exinsps ? exinsps[i] : NULL, 1); } if (SAME_OBJ(exs[i], module_begin_symbol)) saw_mb = 1; if (required) { - vec = scheme_make_vector(9, NULL); + vec = scheme_make_vector(10, NULL); nml = scheme_make_pair(idx, scheme_null); SCHEME_VEC_ELS(vec)[0] = nml; SCHEME_VEC_ELS(vec)[1] = midx; @@ -2229,38 +2226,11 @@ static int do_add_simple_require_renames(Scheme_Object *rn, SCHEME_VEC_ELS(vec)[5] = orig_src; SCHEME_VEC_ELS(vec)[6] = mark_src; SCHEME_VEC_ELS(vec)[7] = (can_override ? scheme_true : scheme_false); - SCHEME_VEC_ELS(vec)[8] = exets ? scheme_make_integer(exets[i]) : 0; + SCHEME_VEC_ELS(vec)[8] = exets ? scheme_make_integer(exets[i]) : scheme_false; + SCHEME_VEC_ELS(vec)[9] = exets ? exinsps[i] : scheme_false; scheme_hash_set(required, exs[i], vec); } } - - if (pt->reprovide_kernel) { - if (!with_shared) { - scheme_extend_module_rename_with_kernel(rn, idx); - } - saw_mb = 1; - - if (required) { - exs = kernel->me->rt->provides; - numvals = kernel->me->rt->num_var_provides; - for (i = kernel->me->rt->num_provides; i--; ) { - if (!SAME_OBJ(pt->kernel_exclusion, exs[i])) { - vec = scheme_make_vector(9, NULL); - nml = scheme_make_pair(idx, scheme_null); - SCHEME_VEC_ELS(vec)[0] = nml; - SCHEME_VEC_ELS(vec)[1] = kernel_modidx; - SCHEME_VEC_ELS(vec)[2] = exs[i]; - SCHEME_VEC_ELS(vec)[3] = ((i < numvals) ? scheme_true : scheme_false); - SCHEME_VEC_ELS(vec)[4] = exs[i]; - SCHEME_VEC_ELS(vec)[5] = orig_src; - SCHEME_VEC_ELS(vec)[6] = mark_src; - SCHEME_VEC_ELS(vec)[7] = (can_override ? scheme_true : scheme_false); - SCHEME_VEC_ELS(vec)[8] = scheme_make_integer(0); - scheme_hash_set(required, exs[i], vec); - } - } - } - } if (!with_shared) { info = cons(idx, cons(marshal_phase_index, @@ -2391,19 +2361,19 @@ void scheme_prep_namespace_rename(Scheme_Env *menv) if (SCHEME_FALSEP(m->me->rt->provide_srcs[i])) { name = m->me->rt->provides[i]; scheme_extend_module_rename(one_rn, m->self_modidx, name, name, m->self_modidx, name, 0, - scheme_make_integer(0), NULL, 0); + scheme_make_integer(0), NULL, NULL, 0); } } /* Local, not provided: */ for (i = 0; i < m->num_indirect_provides; i++) { name = m->indirect_provides[i]; scheme_extend_module_rename(one_rn, m->self_modidx, name, name, m->self_modidx, name, 0, - scheme_make_integer(0), NULL, 0); + scheme_make_integer(0), NULL, NULL, 0); } for (i = 0; i < m->num_indirect_syntax_provides; i++) { name = m->indirect_syntax_provides[i]; scheme_extend_module_rename(one_rn, m->self_modidx, name, name, m->self_modidx, name, 0, - scheme_make_integer(0), NULL, 0); + scheme_make_integer(0), NULL, NULL, 0); } one_rn = scheme_get_module_rename_from_set(rns, scheme_make_integer(1), 1); @@ -3236,9 +3206,10 @@ Scheme_Env *scheme_module_access(Scheme_Object *name, Scheme_Env *env, int rev_m } static void check_certified(Scheme_Object *stx, Scheme_Object *certs, - Scheme_Object *insp, Scheme_Object *in_modidx, + Scheme_Object *prot_insp, Scheme_Object *insp, + Scheme_Object *rename_insp, Scheme_Object *in_modidx, Scheme_Env *env, Scheme_Object *symbol, - int var, int prot) + int var, int prot, int *_would_complain) { int need_cert = 1; Scheme_Object *midx; @@ -3250,8 +3221,20 @@ static void check_certified(Scheme_Object *stx, Scheme_Object *certs, if (need_cert && insp) need_cert = scheme_module_protected_wrt(env->insp, insp); + if (need_cert && rename_insp) { + if (SCHEME_PAIRP(rename_insp)) { + /* First inspector of pair protects second */ + if (!prot_insp + || scheme_module_protected_wrt(SCHEME_CAR(rename_insp), prot_insp)) { + rename_insp = NULL; + } else + rename_insp = SCHEME_CDR(rename_insp); + } + if (rename_insp) + need_cert = scheme_module_protected_wrt(env->insp, rename_insp); + } - if (need_cert && in_modidx) { + if (need_cert && in_modidx && midx) { /* If we're currently executing a macro expander in this module, then allow the access under any cirsumstances. This is mostly useful for syntax-local-value and local-expand. */ @@ -3262,24 +3245,30 @@ static void check_certified(Scheme_Object *stx, Scheme_Object *certs, } if (need_cert) { - /* For error, if stx is no more specific than symbol, drop symbol. */ - if (stx && SAME_OBJ(SCHEME_STX_SYM(stx), symbol)) { - symbol = stx; - stx = NULL; + if (_would_complain) { + *_would_complain = 1; + } else { + /* For error, if stx is no more specific than symbol, drop symbol. */ + if (stx && SAME_OBJ(SCHEME_STX_SYM(stx), symbol)) { + symbol = stx; + stx = NULL; + } + scheme_wrong_syntax("compile", stx, symbol, + "access from an uncertified context to %s %s from module: %D", + prot ? "protected" : "unexported", + var ? "variable" : "syntax", + env->module->modname); } - scheme_wrong_syntax("compile", stx, symbol, - "access from an uncertified context to %s %s from module: %D", - prot ? "protected" : "unexported", - var ? "variable" : "syntax", - env->module->modname); } } Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object *prot_insp, Scheme_Object *in_modidx, Scheme_Object *symbol, Scheme_Object *stx, - Scheme_Object *certs, Scheme_Object *unexp_insp, - int position, int want_pos, int *_protected, - Scheme_Env *from_env) + Scheme_Object *certs, Scheme_Object *unexp_insp, + Scheme_Object *rename_insp, + int position, int want_pos, + int *_protected, int *_unexported, + Scheme_Env *from_env, int *_would_complain) /* Returns the actual name when !want_pos, needed in case of uninterned names. Otherwise, returns a position value on success. If position < -1, then merely checks for protected syntax. @@ -3288,8 +3277,11 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object certifictions in stx+certs, access implied by {prot_,unexp_}insp, or access implied by in_modidx. For unexported access, either stx+certs or unexp_insp must be - supplied (not both). For unprotected access, both prot_insp - and stx+certs should be supplied. */ + supplied (not both), and prot_insp should be supplied + (for protected re-exports of unexported). + For unprotected access, both prot_insp and stx+certs + should be supplied. In either case, rename_insp + is optionally allowed. */ { Scheme_Module_Phase_Exports *pt; @@ -3375,12 +3367,12 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object && provide_protects[position]) { if (_protected) *_protected = 1; - check_certified(stx, certs, prot_insp, in_modidx, env, symbol, 1, 1); + check_certified(stx, certs, prot_insp, prot_insp, rename_insp, in_modidx, env, symbol, 1, 1, _would_complain); } } if (need_cert) - check_certified(stx, certs, unexp_insp, in_modidx, env, symbol, 1, 0); + check_certified(stx, certs, prot_insp, unexp_insp, rename_insp, in_modidx, env, symbol, 1, 0, _would_complain); if (want_pos) return scheme_make_integer(position); @@ -3426,7 +3418,7 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object && provide_protects[SCHEME_INT_VAL(pos)]) { if (_protected) *_protected = 1; - check_certified(stx, certs, prot_insp, in_modidx, env, symbol, 1, 1); + check_certified(stx, certs, prot_insp, prot_insp, rename_insp, in_modidx, env, symbol, 1, 1, _would_complain); } if ((position >= -1) @@ -3434,7 +3426,9 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object /* unexported var -- need cert */ if (_protected) *_protected = 1; - check_certified(stx, certs, unexp_insp, in_modidx, env, symbol, 1, 0); + if (_unexported) + *_unexported = 1; + check_certified(stx, certs, prot_insp, unexp_insp, rename_insp, in_modidx, env, symbol, 1, 0, _would_complain); } if (want_pos) @@ -3445,12 +3439,19 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object if (position < -1) { /* unexported syntax -- need cert */ - check_certified(stx, certs, unexp_insp, in_modidx, env, symbol, 0, 0); + if (_unexported) + *_unexported = 1; + check_certified(stx, certs, prot_insp, unexp_insp, rename_insp, in_modidx, env, symbol, 0, 0, _would_complain); return NULL; } } } + if (_would_complain) { + *_would_complain = 1; + return NULL; + } + /* For error, if stx is no more specific than symbol, drop symbol. */ if (stx && SAME_OBJ(SCHEME_STX_SYM(stx), symbol)) { symbol = stx; @@ -4329,7 +4330,7 @@ void scheme_finish_primitive_module(Scheme_Env *env) m->me->rt->num_provides = count; m->me->rt->num_var_provides = count; - qsort_provides(exs, NULL, NULL, NULL, NULL, NULL, 0, count, 1); + qsort_provides(exs, NULL, NULL, NULL, NULL, NULL, NULL, 0, count, 1); env->running = 1; } @@ -4631,13 +4632,39 @@ static void eval_exptime(Scheme_Object *names, int count, /* module */ /**********************************************************************/ +static Scheme_Object **declare_insps(int n, Scheme_Object **insps, Scheme_Object *insp) +{ + int i; + Scheme_Object **naya, *v; + + for (i = 0; i < n; i++) { + if (insps[i] && SCHEME_PAIRP(insps[i])) + break; + } + if (i >= n) + return insps; + + insp = scheme_make_inspector(insp); + + naya = MALLOC_N(Scheme_Object*, n); + for (i = 0; i < n; i++) { + v = insps[i]; + if (v && SCHEME_PAIRP(v)) { + v = cons(insp, SCHEME_CDR(v)); + } + naya[i] = v; + } + + return naya; +} + static Scheme_Object * module_execute(Scheme_Object *data) { Scheme_Module *m; Scheme_Env *env; Scheme_Env *old_menv; - Scheme_Object *prefix, *insp; + Scheme_Object *prefix, *insp, **rt_insps, **et_insps; m = MALLOC_ONE_TAGGED(Scheme_Module); memcpy(m, data, sizeof(Scheme_Module)); @@ -4682,6 +4709,40 @@ module_execute(Scheme_Object *data) } } + if (m->me->rt->provide_insps) + rt_insps = declare_insps(m->me->rt->num_provides, m->me->rt->provide_insps, insp); + else + rt_insps = NULL; + if (m->me->et->provide_insps) + et_insps = declare_insps(m->me->et->num_provides, m->me->et->provide_insps, insp); + else + et_insps = NULL; + + if (!SAME_OBJ(rt_insps, m->me->rt->provide_insps) + || !SAME_OBJ(et_insps, m->me->et->provide_insps)) { + /* have to clone m->me, etc. */ + Scheme_Module_Exports *naya_me; + Scheme_Module_Phase_Exports *pt; + + naya_me = MALLOC_ONE_TAGGED(Scheme_Module_Exports); + memcpy(naya_me, m->me, sizeof(Scheme_Module_Exports)); + m->me = naya_me; + + if (!SAME_OBJ(rt_insps, m->me->rt->provide_insps)) { + pt = MALLOC_ONE_TAGGED(Scheme_Module_Phase_Exports); + memcpy(pt, m->me->rt, sizeof(Scheme_Module_Phase_Exports)); + m->me->rt = pt; + pt->provide_insps = rt_insps; + } + + if (!SAME_OBJ(rt_insps, m->me->et->provide_insps)) { + pt = MALLOC_ONE_TAGGED(Scheme_Module_Phase_Exports); + memcpy(pt, m->me->et, sizeof(Scheme_Module_Phase_Exports)); + m->me->et = pt; + pt->provide_insps = et_insps; + } + } + m->insp = insp; scheme_hash_set(env->module_registry, m->modname, (Scheme_Object *)m); scheme_hash_set(env->export_registry, m->modname, (Scheme_Object *)m->me); @@ -5313,12 +5374,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, scheme_prepare_exp_env(menv); /* For each provide in iim, add a module rename to fm */ - if (SAME_OBJ(iim, kernel)) { - scheme_extend_module_rename_with_kernel(rn, kernel_modidx); - saw_mb = 1; - } else { - saw_mb = add_simple_require_renames(NULL, rn_set, NULL, iim, iidx, scheme_make_integer(0), NULL, 1); - } + saw_mb = add_simple_require_renames(NULL, rn_set, NULL, iim, iidx, scheme_make_integer(0), NULL, 1); if (rec[drec].comp) benv = scheme_new_comp_env(menv, env->insp, SCHEME_MODULE_FRAME); @@ -5523,7 +5579,7 @@ static void check_require_name(Scheme_Object *prnt_name, Scheme_Object *name, int isval, void *tables, Scheme_Object *e, Scheme_Object *form, Scheme_Object *err_src, Scheme_Object *mark_src, Scheme_Object *phase, Scheme_Object *src_phase_index, - Scheme_Object *nominal_export_phase) + Scheme_Object *nominal_export_phase, Scheme_Object *in_insp) { Scheme_Bucket_Table *toplevel, *syntax; Scheme_Hash_Table *required; @@ -5611,7 +5667,7 @@ static void check_require_name(Scheme_Object *prnt_name, Scheme_Object *name, } /* Remember require: */ - vec = scheme_make_vector(9, NULL); + vec = scheme_make_vector(10, NULL); nml = scheme_make_pair(nominal_modidx, scheme_null); SCHEME_VEC_ELS(vec)[0] = nml; SCHEME_VEC_ELS(vec)[1] = modidx; @@ -5622,6 +5678,7 @@ static void check_require_name(Scheme_Object *prnt_name, Scheme_Object *name, SCHEME_VEC_ELS(vec)[6] = (mark_src ? mark_src : scheme_false); SCHEME_VEC_ELS(vec)[7] = scheme_false; SCHEME_VEC_ELS(vec)[8] = scheme_make_integer(exet); + SCHEME_VEC_ELS(vec)[9] = in_insp; scheme_hash_set(required, name, vec); } @@ -5690,7 +5747,7 @@ static Scheme_Object *add_lifted_defn(Scheme_Object *data, Scheme_Object **_id, scheme_add_global_symbol(name, scheme_undefined, env->genv); /* Add a renaming: */ - scheme_extend_module_rename(rn, self_modidx, name, name, self_modidx, name, 0, NULL, NULL, 0); + scheme_extend_module_rename(rn, self_modidx, name, name, self_modidx, name, 0, NULL, NULL, NULL, 0); id = scheme_add_rename(*_id, rn); *_id = id; @@ -5803,7 +5860,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Object *post_ex_rn, *post_ex_et_rn; /* renames for ids introduced by expansion */ Scheme_Object *post_ex_rn_set; /* phase -> post_ex_rn-like rename */ Scheme_Hash_Table *tables; /* phase -> (vector toplevels requires syntaxes) */ - Scheme_Object *exclude_hint = scheme_false, *lift_data; + Scheme_Object *lift_data; Scheme_Object **exis, **et_exis, **exsis; Scheme_Object *lift_ctx; Scheme_Object *lifted_reqs = scheme_null, *req_data; @@ -5811,7 +5868,6 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, char *exps, *et_exps; int *all_simple_renames; int maybe_has_lifts = 0; - int reprovide_kernel; Scheme_Object *redef_modname; Scheme_Object *observer; @@ -6098,10 +6154,10 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, /* Add a renaming: */ if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name)) { - scheme_extend_module_rename(post_ex_rn, self_modidx, name, name, self_modidx, name, 0, NULL, NULL, 0); + scheme_extend_module_rename(post_ex_rn, self_modidx, name, name, self_modidx, name, 0, NULL, NULL, NULL, 0); *all_simple_renames = 0; } else - scheme_extend_module_rename(rn, self_modidx, name, name, self_modidx, name, 0, NULL, NULL, 0); + scheme_extend_module_rename(rn, self_modidx, name, name, self_modidx, name, 0, NULL, NULL, NULL, 0); vars = SCHEME_STX_CDR(vars); } @@ -6183,12 +6239,12 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name)) { scheme_extend_module_rename(for_stx ? post_ex_et_rn : post_ex_rn, self_modidx, name, name, self_modidx, name, - for_stx ? 1 : 0, NULL, NULL, 0); + for_stx ? 1 : 0, NULL, NULL, NULL, 0); *all_simple_renames = 0; use_post_ex = 1; } else scheme_extend_module_rename(for_stx ? et_rn : rn, self_modidx, name, name, self_modidx, name, - for_stx ? 1 : 0, NULL, NULL, 0); + for_stx ? 1 : 0, NULL, NULL, NULL, 0); count++; } @@ -6493,60 +6549,19 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, scheme_seal_module_rename_set(post_ex_rn_set, STX_SEAL_ALL); /* Compute provides for re-provides and all-defs-out: */ - reprovide_kernel = compute_reprovides(all_provided, - all_reprovided, - env->genv->module, - tables, - env->genv, - all_defs, all_defs_out, - all_et_defs, all_et_defs_out, - &exclude_hint, - "require", NULL, NULL); - - /* Ad hoc optimization: some early modules are everything from kernel except - #%module_begin */ - if ((reprovide_kernel == (kernel->me->rt->num_provides - 1)) - && SCHEME_FALSEP(exclude_hint)) { - exclude_hint = scheme_make_pair(module_begin_symbol, scheme_null); - exclude_hint = scheme_datum_to_syntax(exclude_hint, scheme_false, scheme_top_stx, 0, 0); - } - - /* Re-providing all of the kernel without prefixing? */ - if (reprovide_kernel) { - if ((reprovide_kernel == (kernel->me->rt->num_provides - 1)) - && SCHEME_TRUEP(exclude_hint)) { - if (SCHEME_STX_PAIRP(exclude_hint) && SCHEME_NULLP(SCHEME_STX_CDR(exclude_hint))) { - Scheme_Object *n; - - exclude_hint = SCHEME_STX_CAR(exclude_hint); - exclude_hint = SCHEME_STX_VAL(exclude_hint); - n = scheme_hash_get(provided, exclude_hint); - if (n) { - /* may be a single shadowed exclusion, now bound to exclude_hint... */ - n = SCHEME_CAR(n); - if (SCHEME_STXP(n)) - n = scheme_tl_id_sym(env->genv, n, NULL, -1, NULL, NULL); - n = scheme_hash_get(required, n); - if (n && !SAME_OBJ(SCHEME_VEC_ELS(n)[1], kernel_modidx)) { - /* there is a single shadowed exclusion. */ - } else - reprovide_kernel = 0; - } else - reprovide_kernel = 0; - } else - reprovide_kernel = 0; - } else if (reprovide_kernel != kernel->me->rt->num_provides) - reprovide_kernel = 0; - else - exclude_hint = scheme_false; - } - /* If reprovide_kernel is non-zero, we re-provide all of it */ + (void)compute_reprovides(all_provided, + all_reprovided, + env->genv->module, + tables, + env->genv, + all_defs, all_defs_out, + all_et_defs, all_et_defs_out, + "require", NULL, NULL); /* Compute provide arrays */ exps = compute_provide_arrays(all_provided, tables, env->genv->module->me, env->genv, - reprovide_kernel, form, &et_exps); /* Compute indirect provides (which is everything at the top-level): */ @@ -6585,14 +6600,8 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, result = scheme_null; - /* kernel re-export info: */ - if (reprovide_kernel) { - if (exclude_hint) - result = scheme_make_pair(exclude_hint, result); - else - result = scheme_make_pair(scheme_true, result); - } else - result = scheme_make_pair(scheme_false, result); + /* kernel re-export info (always #f): */ + result = scheme_make_pair(scheme_false, result); /* Indirect provides */ a = scheme_null; @@ -6607,24 +6616,6 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, e = scheme_null; - if (reprovide_kernel) { - if (!j) { - i = kernel->me->rt->num_var_provides; - top = kernel->me->rt->num_provides; - } else { - i = 0; - top = kernel->me->rt->num_var_provides; - } - - for (; i < top; i++) { - if (!SAME_OBJ(kernel->me->rt->provides[i], exclude_hint)) { - a = scheme_make_pair(kernel->me->rt->provides[i], kernel->me->rt->provides[i]); - a = scheme_make_pair(kernel_modidx, a); - e = scheme_make_pair(a, e); - } - } - } - if (!j) { i = exvcount; top = excount; @@ -6669,9 +6660,6 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, env->genv->module->provide_protects = exps; env->genv->module->et_provide_protects = et_exps; - env->genv->module->me->rt->reprovide_kernel = reprovide_kernel; - env->genv->module->me->rt->kernel_exclusion = exclude_hint; - env->genv->module->indirect_provides = exis; env->genv->module->num_indirect_provides = exicount; @@ -6750,7 +6738,6 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, Scheme_Env *_genv, Scheme_Object *all_rt_defs, Scheme_Object *all_rt_defs_out, Scheme_Object *all_et_defs, Scheme_Object *all_et_defs_out, - Scheme_Object **_exclude_hint, const char *matching_form, Scheme_Object *all_mods, /* a phase list to use for all mods */ Scheme_Object *all_phases) /* a module-path list for all phases */ @@ -6759,7 +6746,6 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, Scheme_Object *reprovided, *tvec; int i, k, z; Scheme_Object *rx, *provided_list, *phase, *req_phase; - int reprovide_kernel = 0; Scheme_Object *all_defs, *all_defs_out; Scheme_Env *genv; @@ -6846,7 +6832,7 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, "cannot provide from a module without a matching `%s'", matching_form); } else { - return -1; + return 0; } } @@ -6942,11 +6928,6 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, ree = SCHEME_CDR(SCHEME_CAR(rx)); exns = SCHEME_CDR(ree); - if (SAME_OBJ(modidx, kernel_modidx)) - if (!SCHEME_STX_NULLP(exns)) { - if (SAME_OBJ(phase, scheme_make_integer(0)) && _exclude_hint) - *_exclude_hint = exns; - } } else { ree = NULL; exns = scheme_null; @@ -6997,10 +6978,6 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, provided_list = scheme_make_pair(name, provided_list); scheme_hash_set(all_provided, req_phase, provided_list); } - - if (SAME_OBJ(phase, scheme_make_integer(0))) - if (SAME_OBJ(modidx, kernel_modidx) && SAME_OBJ(outname, srcname)) - reprovide_kernel++; } } } @@ -7096,7 +7073,7 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, } } - return reprovide_kernel; + return 1; } static Scheme_Object **compute_indirects(Scheme_Env *genv, @@ -7167,7 +7144,7 @@ static Scheme_Object **compute_indirects(Scheme_Env *genv, exicount = count; - qsort_provides(exis, NULL, NULL, NULL, NULL, NULL, 0, exicount, 1); + qsort_provides(exis, NULL, NULL, NULL, NULL, NULL, NULL, 0, exicount, 1); *_count = exicount; return exis; @@ -7216,10 +7193,10 @@ Scheme_Object *scheme_module_imported_list(Scheme_Env *genv, Scheme_Object *bind tables, genv, NULL, NULL, NULL, NULL, - NULL, NULL, + NULL, all_mods, all_phases); - if (v < 0) { + if (!v) { return scheme_false; } else { l = scheme_null; @@ -7279,7 +7256,8 @@ static Scheme_Object *extract_free_id_name(Scheme_Object *name, Scheme_Object **_implicit_src_name, Scheme_Object **_implicit_mod_phase, Scheme_Object **_implicit_nominal_name, - Scheme_Object **_implicit_nominal_mod) + Scheme_Object **_implicit_nominal_mod, + Scheme_Object **_implicit_insp) { *_implicit = 0; @@ -7300,29 +7278,72 @@ static Scheme_Object *extract_free_id_name(Scheme_Object *name, v2 = scheme_lookup_in_table(genv->syntax, (const char *)name); if (v2 && scheme_is_binding_rename_transformer(SCHEME_PTR_VAL(v2))) { Scheme_Object *name2; - Scheme_Object *mod, *id; + Scheme_Object *mod, *id, *rename_insp = NULL; + Scheme_Object *mod_phase = NULL; name2 = scheme_rename_transformer_id(SCHEME_PTR_VAL(v2)); id = name2; - mod = scheme_stx_module_name(0, &id, phase, + + if (_implicit_mod_phase) mod_phase = *_implicit_mod_phase; + mod = scheme_stx_module_name(NULL, &id, phase, _implicit_nominal_mod, _implicit_nominal_name, - _implicit_mod_phase, - NULL, NULL, NULL, NULL); + &mod_phase, + NULL, NULL, NULL, NULL, &rename_insp); + if (_implicit_mod_phase) *_implicit_mod_phase = mod_phase; + if (mod && SAME_TYPE(SCHEME_TYPE(mod), scheme_module_index_type)) { if (SCHEME_FALSEP(((Scheme_Modidx *)mod)->path)) { /* keep looking locally */ name = name2; SCHEME_USE_FUEL(1); } else { - /* free-id=? equivalence to a name that is not necessarily imported explicitly */ - if (_implicit_src) { - *_implicit_src = mod; - *_implicit_src_name = id; - name2 = scheme_stx_property(name2, nominal_id_symbol, NULL); - if (SCHEME_SYMBOLP(name2)) - *_implicit_nominal_name = name2; + /* free-id=? equivalence to a name that is not necessarily imported explicitly. */ + int would_complain = 0, is_prot = 0, is_unexp = 0; + + if (!SCHEME_FALSEP(phase)) { + /* Check whether reference is certified, and ignore it if not: */ + Scheme_Env *menv; + Scheme_Object *modname; + + modname = scheme_module_resolve(mod, 1); + menv = scheme_module_access(modname, genv, SCHEME_INT_VAL(mod_phase)); + if (!menv) + would_complain = 1; + else { + scheme_check_accessible_in_module(menv, menv->module->insp, mod, + SCHEME_STX_VAL(name2), name2, + NULL, NULL, rename_insp, + -1, 0, + &is_prot, &is_unexp, genv, &would_complain); + if (would_complain && (!is_prot && !is_unexp)) { + /* Must be unexported syntax */ + is_prot = is_unexp = would_complain = 0; + scheme_check_accessible_in_module(menv, menv->module->insp, mod, + SCHEME_STX_VAL(name2), name2, + NULL, NULL, rename_insp, + -2, 0, + &is_prot, &is_unexp, genv, &would_complain); + } + } + } + + + if (!would_complain) { + if (_implicit_src) { + *_implicit_src = mod; + *_implicit_src_name = id; + if (is_prot || is_unexp) { + if (rename_insp) + *_implicit_insp = rename_insp; + else + *_implicit_insp = genv->module->insp; + } + name2 = scheme_stx_property(name2, nominal_id_symbol, NULL); + if (SCHEME_SYMBOLP(name2)) + *_implicit_nominal_name = name2; + } + *_implicit = 1; } - *_implicit = 1; break; } } else @@ -7339,18 +7360,18 @@ static Scheme_Object *extract_free_id_name(Scheme_Object *name, char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table *tables, Scheme_Module_Exports *me, Scheme_Env *genv, - int reprovide_kernel, Scheme_Object *form, char **_phase1_protects) { int i, count, z, implicit; - Scheme_Object **exs, **exsns, **exss, **exsnoms, *phase; + Scheme_Object **exs, **exsns, **exss, **exsnoms, **exinsps, *phase; Scheme_Hash_Table *provided, *required; char *exps, *exets, *phase0_exps = NULL, *phase1_exps = NULL; int excount, exvcount; Scheme_Module_Phase_Exports *pt; Scheme_Object *implicit_src, *implicit_src_name, *implicit_mod_phase; Scheme_Object *implicit_nominal_name, *implicit_nominal_mod; + Scheme_Object *implicit_insp; for (z = 0; z < all_provided->size; z++) { provided = (Scheme_Hash_Table *)all_provided->vals[z]; @@ -7384,13 +7405,11 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table count++; } - if (SAME_OBJ(phase, scheme_make_integer(0))) - count -= reprovide_kernel; - exs = MALLOC_N(Scheme_Object *, count); exsns = MALLOC_N(Scheme_Object *, count); exss = MALLOC_N(Scheme_Object *, count); exsnoms = MALLOC_N(Scheme_Object *, count); + exinsps = MALLOC_N(Scheme_Object *, count); exps = MALLOC_N_ATOMIC(char, count); exets = MALLOC_N_ATOMIC(char, count); memset(exets, 0, count); @@ -7408,7 +7427,7 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table name = extract_free_id_name(name, phase, genv, 1, &implicit, NULL, NULL, NULL, - NULL, NULL); + NULL, NULL, NULL); if (!implicit && genv @@ -7441,24 +7460,19 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table scheme_wrong_syntax("module", NULL, name, "cannot protect imported identifier with re-provide"); } if (SCHEME_TRUEP(SCHEME_VEC_ELS(v)[3])) { - /* If this is a kernel re-provide, don't provide after all. */ - if ((reprovide_kernel && SAME_OBJ(phase, scheme_make_integer(0))) - && SAME_OBJ(SCHEME_VEC_ELS(v)[1], kernel_modidx) - && SAME_OBJ(provided->keys[i], SCHEME_VEC_ELS(v)[2])) { - /* skip */ - } else { - Scheme_Object *noms; - exs[count] = provided->keys[i]; - exsns[count] = SCHEME_VEC_ELS(v)[2]; - exss[count] = SCHEME_VEC_ELS(v)[1]; - noms = adjust_for_rename(exs[count], SCHEME_VEC_ELS(v)[4], SCHEME_VEC_ELS(v)[0]); - exsnoms[count] = noms; - exps[count] = protected; - if (SAME_OBJ(SCHEME_VEC_ELS(v)[8], scheme_make_integer(1))) - exets[count] = 1; - - count++; - } + Scheme_Object *noms; + exs[count] = provided->keys[i]; + exsns[count] = SCHEME_VEC_ELS(v)[2]; + exss[count] = SCHEME_VEC_ELS(v)[1]; + noms = adjust_for_rename(exs[count], SCHEME_VEC_ELS(v)[4], SCHEME_VEC_ELS(v)[0]); + exsnoms[count] = noms; + exps[count] = protected; + if (SAME_OBJ(SCHEME_VEC_ELS(v)[8], scheme_make_integer(1))) + exets[count] = 1; + if (SCHEME_TRUEP(SCHEME_VEC_ELS(v)[9])) + exinsps[count] = SCHEME_VEC_ELS(v)[9]; + + count++; } } else { /* Not defined! */ @@ -7481,7 +7495,8 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table name = extract_free_id_name(name, phase, genv, 0, &implicit, &implicit_src, &implicit_src_name, &implicit_mod_phase, - &implicit_nominal_name, &implicit_nominal_mod); + &implicit_nominal_name, &implicit_nominal_mod, + &implicit_insp); if (!implicit && genv @@ -7495,33 +7510,34 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table exps[count] = protected; count++; } else if (implicit) { - /* We record all free-id=?-based exprts as synatx, even though they may be values. */ + /* We record all free-id=?-based exprts as syntax, even though they may be values. */ Scheme_Object *noms; exs[count] = provided->keys[i]; exsns[count] = implicit_src_name; exss[count] = implicit_src; noms = adjust_for_rename(exs[count], implicit_nominal_name, cons(implicit_nominal_mod, scheme_null)); exsnoms[count] = noms; - exps[count] = protected; + exps[count] = protected; + if (implicit_insp) { + if (protected) { + implicit_insp = cons(genv->insp, implicit_insp); + } + exinsps[count] = implicit_insp; + } count++; } else if ((v = scheme_hash_get(required, name))) { /* Required */ if (SCHEME_FALSEP(SCHEME_VEC_ELS(v)[3])) { - /* If this is a kernel re-provide, don't provide after all. */ - if ((reprovide_kernel && SAME_OBJ(phase, scheme_make_integer(0))) - && SAME_OBJ(SCHEME_VEC_ELS(v)[1], kernel_modidx) - && SAME_OBJ(provided->keys[i], SCHEME_VEC_ELS(v)[2])) { - /* skip */ - } else { - Scheme_Object *noms; - exs[count] = provided->keys[i]; - exsns[count] = SCHEME_VEC_ELS(v)[2]; - exss[count] = SCHEME_VEC_ELS(v)[1]; - noms = adjust_for_rename(exs[count], SCHEME_VEC_ELS(v)[4], SCHEME_VEC_ELS(v)[0]); - exsnoms[count] = noms; - exps[count] = protected; - count++; - } + Scheme_Object *noms; + exs[count] = provided->keys[i]; + exsns[count] = SCHEME_VEC_ELS(v)[2]; + exss[count] = SCHEME_VEC_ELS(v)[1]; + noms = adjust_for_rename(exs[count], SCHEME_VEC_ELS(v)[4], SCHEME_VEC_ELS(v)[0]); + exsnoms[count] = noms; + exps[count] = protected; + if (SCHEME_TRUEP(SCHEME_VEC_ELS(v)[9])) + exinsps[count] = SCHEME_VEC_ELS(v)[9]; + count++; } } } @@ -7538,17 +7554,16 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table exsnoms = NULL; } - /* Sort provide array for variables: interned followed by - uninterned, alphabetical within each. This is important for - having a consistent provide arrays. */ - qsort_provides(exs, exsns, exss, exps, exets, exsnoms, 0, exvcount, 1); + /* Discard exinsps if there are no inspectors */ + for (i = 0; i < excount; i++) { + if (exinsps[i]) + break; + } + if (i >= excount) { + exinsps = NULL; + } - pt->num_provides = excount; - pt->num_var_provides = exvcount; - pt->provides = exs; - pt->provide_src_names = exsns; - pt->provide_srcs = exss; - pt->provide_nominal_srcs = exsnoms; + /* Discard exets if all 0 */ if (exets) { for (i = 0; i < excount; i++) { if (exets[i]) @@ -7557,6 +7572,19 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table if (i >= excount) exets = NULL; } + + /* Sort provide array for variables: interned followed by + uninterned, alphabetical within each. This is important for + having a consistent provide arrays. */ + qsort_provides(exs, exsns, exss, exps, exets, exsnoms, exinsps, 0, exvcount, 1); + + pt->num_provides = excount; + pt->num_var_provides = exvcount; + pt->provides = exs; + pt->provide_src_names = exsns; + pt->provide_srcs = exss; + pt->provide_nominal_srcs = exsnoms; + pt->provide_insps = exinsps; pt->provide_src_phases = exets; if (SAME_OBJ(phase, scheme_make_integer(0))) @@ -7574,11 +7602,11 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table /* Helper: */ static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Object **exss, char *exps, char *exets, - Scheme_Object **exsnoms, + Scheme_Object **exsnoms, Scheme_Object **exinsps, int start, int count, int do_uninterned) { int i, j; - Scheme_Object *tmp_ex, *tmp_exsn, *tmp_exs, *tmp_exsnom, *pivot; + Scheme_Object *tmp_ex, *tmp_exsn, *tmp_exs, *tmp_exsnom, *tmp_exinsp, *pivot; char tmp_exp, tmp_exet; if (do_uninterned) { @@ -7620,6 +7648,13 @@ static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Ob exsnoms[j] = tmp_exsnom; } + if (exinsps) { + tmp_exinsp = exinsps[i]; + + exinsps[i] = exinsps[j]; + + exinsps[j] = tmp_exinsp; + } j--; /* Skip over uninterns already at the end: */ @@ -7633,8 +7668,8 @@ static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Ob } /* Sort interned and uninterned separately: */ - qsort_provides(exs, exsns, exss, exps, exets, exsnoms, 0, j + 1, 0); - qsort_provides(exs, exsns, exss, exps, exets, exsnoms, j + 1, count - j - 1, 0); + qsort_provides(exs, exsns, exss, exps, exets, exsnoms, exinsps, 0, j + 1, 0); + qsort_provides(exs, exsns, exss, exps, exets, exsnoms, exinsps, j + 1, count - j - 1, 0); } else { j = start; while (count > 1) { @@ -7666,7 +7701,6 @@ static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Ob exets[k] = exets[j]; exets[j] = tmp_exet; } - if (exsnoms) { tmp_exsnom = exsnoms[k]; @@ -7674,6 +7708,13 @@ static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Ob exsnoms[j] = tmp_exsnom; } + if (exinsps) { + tmp_exinsp = exinsps[k]; + + exinsps[k] = exinsps[j]; + + exinsps[j] = tmp_exinsp; + } j++; } @@ -7687,8 +7728,8 @@ static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Ob } if (count > 1) { - qsort_provides(exs, exsns, exss, exps, exets, exsnoms, start, j - start, 0); - qsort_provides(exs, exsns, exss, exps, exets, exsnoms, j, count - (j - start), 0); + qsort_provides(exs, exsns, exss, exps, exets, exsnoms, exinsps, start, j - start, 0); + qsort_provides(exs, exsns, exss, exps, exets, exsnoms, exinsps, j, count - (j - start), 0); } } } @@ -8255,9 +8296,9 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */ { int j, var_count; Scheme_Object *orig_idx = idx, *to_phase; - Scheme_Object **exs, **exsns, **exss, *context_marks = scheme_null; + Scheme_Object **exs, **exsns, **exss, *context_marks = scheme_null, **exinsps; char *exets; - int is_kern, has_context, save_marshal_info = 0; + int has_context, save_marshal_info = 0; Scheme_Object *nominal_modidx, *one_exn, *prnt_iname, *name, *rn, *ename = orig_ename; Scheme_Hash_Table *orig_onlys; int k, skip_rename, do_copy_vars; @@ -8316,14 +8357,6 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */ to_phase = NULL; if (pt) { - is_kern = (SAME_OBJ(idx, kernel_modidx) - && !exns - && !onlys - && !prefix - && !iname - && !unpack_kern - && !has_context); - one_exn = NULL; nominal_modidx = idx; @@ -8344,7 +8377,7 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */ && !exns && !prefix && !orig_ename - && (pt->num_provides || pt->reprovide_kernel) + && pt->num_provides && !do_copy_vars) { /* Simple "import everything" whose mappings can be shared via the exporting module: */ if (!pt->src_modidx) @@ -8354,150 +8387,134 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */ } else skip_rename = 0; - while (1) { /* loop to handle kernel re-provides... */ - int break_if_iname_null = !!iname; - - exs = pt->provides; - exsns = pt->provide_src_names; - exss = pt->provide_srcs; - exets = pt->provide_src_phases; - var_count = pt->num_var_provides; - - for (j = pt->num_provides; j--; ) { - Scheme_Object *modidx; - - if (orig_ename) { - if (!SAME_OBJ(SCHEME_STX_VAL(orig_ename), exs[j])) - continue; /* we don't want this one. */ - } else if (onlys) { - name = scheme_hash_get(orig_onlys, exs[j]); - if (!name) - continue; /* we don't want this one. */ - mark_src = name; - { - Scheme_Object *l; - l = scheme_stx_extract_marks(mark_src); - has_context = !SCHEME_NULLP(l); - } - /* Remove to indicate that it's been imported: */ - scheme_hash_set(onlys, exs[j], NULL); - } else { - if (exns) { - Scheme_Object *l, *a; - for (l = exns; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - a = SCHEME_STX_CAR(l); - if (SCHEME_STXP(a)) - a = SCHEME_STX_VAL(a); - if (SAME_OBJ(a, exs[j])) - break; - } - if (!SCHEME_STX_NULLP(l)) - continue; /* we don't want this one. */ - } - - if (one_exn) { - if (SAME_OBJ(one_exn, exs[j])) - continue; /* we don't want this one. */ - } - } - - modidx = ((exss && !SCHEME_FALSEP(exss[j])) - ? scheme_modidx_shift(exss[j], me->src_modidx, idx) - : idx); + exs = pt->provides; + exsns = pt->provide_src_names; + exss = pt->provide_srcs; + exets = pt->provide_src_phases; + exinsps = pt->provide_insps; + var_count = pt->num_var_provides; - if (!iname) - iname = exs[j]; - - if (SCHEME_SYM_WEIRDP(iname)) { - /* This shouldn't happen. In case it does, don't import a - gensym or parallel symbol. The former is useless. The - latter is supposed to be module-specific, and it could - collide with local module-specific ids. */ - iname = NULL; - continue; - } - - if (prefix) - iname = scheme_symbol_append(prefix, iname); - - prnt_iname = iname; - if (has_context) { - /* The `require' expression has a set of marks in its - context, which means that we need to generate a name. */ - iname = scheme_datum_to_syntax(iname, scheme_false, mark_src, 0, 0); - iname = scheme_tl_id_sym(orig_env, iname, scheme_false, skip_rename ? 3 : 2, to_phase, NULL); - if (all_simple) - *all_simple = 0; - } - - if (ck) - ck(prnt_iname, iname, nominal_modidx, exs[j], modidx, exsns[j], exets ? exets[j] : 0, - (j < var_count), - data, cki, form, err_src, mark_src, to_phase, src_phase_index, pt->phase_index); - - if (!is_kern) { - int done; - - if (do_copy_vars && (j < var_count)) { - Scheme_Env *menv; - Scheme_Object *val, *modname; - Scheme_Bucket *b; - modname = scheme_module_resolve(modidx, 1); - menv = scheme_module_access(modname, orig_env, 0); - val = scheme_lookup_in_table(menv->toplevel, (char *)exsns[j]); - b = scheme_global_bucket(iname, orig_env); - scheme_set_global_bucket(((copy_vars == 2) - ? "namespace-require/constant" - : "namespace-require/copy"), - b, val, 1); - if (copy_vars == 2) { - ((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_IMMUTATED; - done = 0; - } else { - scheme_shadow(orig_env, iname, 1); - done = 1; - } - } else - done = 0; - - if (done) { - } else if (!for_unmarshal || !has_context) { - if (!skip_rename) { - if (!save_marshal_info && !has_context && can_save_marshal) - save_marshal_info = 1; - - scheme_extend_module_rename(rn, - modidx, iname, exsns[j], nominal_modidx, exs[j], - exets ? exets[j] : 0, - src_phase_index, - pt->phase_index, - (for_unmarshal || (!has_context && can_save_marshal)) ? 1 : 0); - } - } - } - - iname = NULL; + for (j = pt->num_provides; j--; ) { + Scheme_Object *modidx; - if (ename) { - ename = NULL; - break; + if (orig_ename) { + if (!SAME_OBJ(SCHEME_STX_VAL(orig_ename), exs[j])) + continue; /* we don't want this one. */ + } else if (onlys) { + name = scheme_hash_get(orig_onlys, exs[j]); + if (!name) + continue; /* we don't want this one. */ + mark_src = name; + { + Scheme_Object *l; + l = scheme_stx_extract_marks(mark_src); + has_context = !SCHEME_NULLP(l); + } + /* Remove to indicate that it's been imported: */ + scheme_hash_set(onlys, exs[j], NULL); + } else { + if (exns) { + Scheme_Object *l, *a; + for (l = exns; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { + a = SCHEME_STX_CAR(l); + if (SCHEME_STXP(a)) + a = SCHEME_STX_VAL(a); + if (SAME_OBJ(a, exs[j])) + break; + } + if (!SCHEME_STX_NULLP(l)) + continue; /* we don't want this one. */ + } + + if (one_exn) { + if (SAME_OBJ(one_exn, exs[j])) + continue; /* we don't want this one. */ + } + } + + modidx = ((exss && !SCHEME_FALSEP(exss[j])) + ? scheme_modidx_shift(exss[j], me->src_modidx, idx) + : idx); + + if (!iname) + iname = exs[j]; + + if (SCHEME_SYM_WEIRDP(iname)) { + /* This shouldn't happen. In case it does, don't import a + gensym or parallel symbol. The former is useless. The + latter is supposed to be module-specific, and it could + collide with local module-specific ids. */ + iname = NULL; + continue; + } + + if (prefix) + iname = scheme_symbol_append(prefix, iname); + + prnt_iname = iname; + if (has_context) { + /* The `require' expression has a set of marks in its + context, which means that we need to generate a name. */ + iname = scheme_datum_to_syntax(iname, scheme_false, mark_src, 0, 0); + iname = scheme_tl_id_sym(orig_env, iname, scheme_false, skip_rename ? 3 : 2, to_phase, NULL); + if (all_simple) + *all_simple = 0; + } + + if (ck) + ck(prnt_iname, iname, nominal_modidx, exs[j], modidx, exsns[j], exets ? exets[j] : 0, + (j < var_count), + data, cki, form, err_src, mark_src, to_phase, src_phase_index, pt->phase_index, + exinsps ? exinsps[j] : scheme_false); + + { + int done; + + if (do_copy_vars && (j < var_count)) { + Scheme_Env *menv; + Scheme_Object *val, *modname; + Scheme_Bucket *b; + modname = scheme_module_resolve(modidx, 1); + menv = scheme_module_access(modname, orig_env, 0); + val = scheme_lookup_in_table(menv->toplevel, (char *)exsns[j]); + b = scheme_global_bucket(iname, orig_env); + scheme_set_global_bucket(((copy_vars == 2) + ? "namespace-require/constant" + : "namespace-require/copy"), + b, val, 1); + if (copy_vars == 2) { + ((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_IMMUTATED; + done = 0; + } else { + scheme_shadow(orig_env, iname, 1); + done = 1; + } + } else + done = 0; + + if (done) { + } else if (!for_unmarshal || !has_context) { + if (!skip_rename) { + if (!save_marshal_info && !has_context && can_save_marshal) + save_marshal_info = 1; + + scheme_extend_module_rename(rn, + modidx, iname, exsns[j], nominal_modidx, exs[j], + exets ? exets[j] : 0, + src_phase_index, + pt->phase_index, + exinsps ? exinsps[j] : NULL, + (for_unmarshal || (!has_context && can_save_marshal)) ? 1 : 0); + } } } - if (is_kern && !skip_rename) - scheme_extend_module_rename_with_kernel(rn, nominal_modidx); - - if (break_if_iname_null && !iname) - break; - - if (pt->reprovide_kernel) { - idx = kernel_modidx; - one_exn = pt->kernel_exclusion; - me = kernel->me; - pt = kernel->me->rt; - is_kern = !prefix && !unpack_kern && !ename && !has_context && !onlys; - } else + iname = NULL; + + if (ename) { + ename = NULL; break; + } } if (save_marshal_info) { @@ -9028,7 +9045,7 @@ static void check_dup_require(Scheme_Object *prnt_name, Scheme_Object *name, int isval, void *ht, Scheme_Object *e, Scheme_Object *form, Scheme_Object *err_src, Scheme_Object *mark_src, Scheme_Object *to_phase, Scheme_Object *src_phase_index, - Scheme_Object *nominal_export_phase) + Scheme_Object *nominal_export_phase, Scheme_Object *in_insp) { Scheme_Object *i; @@ -9328,6 +9345,20 @@ static Scheme_Object *write_module(Scheme_Object *obj) v = scheme_false; l = cons(v, l); + if (pt->provide_insps) { + v = scheme_make_vector(count, scheme_false); + for (i = 0; i < count; i++) { + if (pt->provide_insps[i]) { + if (SCHEME_PAIRP(pt->provide_insps[i])) + SCHEME_VEC_ELS(v)[i] = scheme_void; + else + SCHEME_VEC_ELS(v)[i] = scheme_true; + } + } + } else + v = scheme_false; + l = cons(v, l); + l = cons(pt->phase_index, l); cnt++; } @@ -9393,9 +9424,6 @@ static Scheme_Object *write_module(Scheme_Object *obj) } l = cons(v, l); - l = cons(m->me->rt->reprovide_kernel ? scheme_true : scheme_false, l); - l = cons(m->me->rt->kernel_exclusion, l); - l = cons((Scheme_Object *)m->prefix, l); l = cons(m->dummy, l); @@ -9439,8 +9467,8 @@ static int check_requires_ok(Scheme_Object *l) static Scheme_Object *read_module(Scheme_Object *obj) { Scheme_Module *m; - Scheme_Object *ie, *nie; - Scheme_Object *eesp, *esp, *esn, *esph, *es, *esnom, *e, *nve, *ne, **v; + Scheme_Object *ie, *nie, *insp; + Scheme_Object *eesp, *esp, *esn, *esph, *es, *esnom, *einsp, *e, *nve, *ne, **v; Scheme_Module_Exports *me; Scheme_Module_Phase_Exports *pt; char *ps, *sps; @@ -9501,13 +9529,6 @@ static Scheme_Object *read_module(Scheme_Object *obj) m->prefix = (Resolve_Prefix *)SCHEME_CAR(obj); obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return_NULL(); - me->rt->kernel_exclusion = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return_NULL(); - me->rt->reprovide_kernel = SCHEME_TRUEP(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return_NULL(); ie = SCHEME_CAR(obj); obj = SCHEME_CDR(obj); @@ -9604,6 +9625,10 @@ static Scheme_Object *read_module(Scheme_Object *obj) scheme_hash_set(me->other_phases, phase, (Scheme_Object *)pt); } + if (!SCHEME_PAIRP(obj)) return_NULL(); + einsp = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + if (!SCHEME_PAIRP(obj)) return_NULL(); esph = SCHEME_CAR(obj); obj = SCHEME_CDR(obj); @@ -9678,6 +9703,24 @@ static Scheme_Object *read_module(Scheme_Object *obj) } } pt->provide_src_phases = sps; + + if (SCHEME_FALSEP(einsp)) { + pt->provide_insps = NULL; + } else { + if (!SCHEME_VECTORP(einsp) || (SCHEME_VEC_SIZE(einsp) != count)) return_NULL(); + insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); + v = MALLOC_N(Scheme_Object *, count); + for (i = 0; i < count; i++) { + if (SCHEME_TRUEP(SCHEME_VEC_ELS(einsp)[i])) { + if (SCHEME_VOIDP(SCHEME_VEC_ELS(einsp)[i])) { + e = cons(scheme_false, insp); + v[i] = e; + } else + v[i] = insp; + } + } + pt->provide_insps = v; + } } count = me->rt->num_provides; diff --git a/src/mzscheme/src/mzmark.c b/src/mzscheme/src/mzmark.c index 277bcb6bda..80985c8c22 100644 --- a/src/mzscheme/src/mzmark.c +++ b/src/mzscheme/src/mzmark.c @@ -2465,6 +2465,7 @@ static int module_phase_exports_val_MARK(void *p) { gcMARK(m->provide_src_names); gcMARK(m->provide_nominal_srcs); gcMARK(m->provide_src_phases); + gcMARK(m->provide_insps); gcMARK(m->kernel_exclusion); gcMARK(m->kernel_exclusion2); @@ -2487,6 +2488,7 @@ static int module_phase_exports_val_FIXUP(void *p) { gcFIXUP(m->provide_src_names); gcFIXUP(m->provide_nominal_srcs); gcFIXUP(m->provide_src_phases); + gcFIXUP(m->provide_insps); gcFIXUP(m->kernel_exclusion); gcFIXUP(m->kernel_exclusion2); @@ -5043,7 +5045,6 @@ static int mark_rename_table_MARK(void *p) { gcMARK(rn->nomarshal_ht); gcMARK(rn->unmarshal_info); gcMARK(rn->shared_pes); - gcMARK(rn->plus_kernel_nominal_source); gcMARK(rn->set_identity); gcMARK(rn->marked_names); gcMARK(rn->free_id_renames); @@ -5058,7 +5059,6 @@ static int mark_rename_table_FIXUP(void *p) { gcFIXUP(rn->nomarshal_ht); gcFIXUP(rn->unmarshal_info); gcFIXUP(rn->shared_pes); - gcFIXUP(rn->plus_kernel_nominal_source); gcFIXUP(rn->set_identity); gcFIXUP(rn->marked_names); gcFIXUP(rn->free_id_renames); @@ -5216,6 +5216,40 @@ static int lex_rib_FIXUP(void *p) { #define lex_rib_IS_CONST_SIZE 1 +static int mark_free_id_info_SIZE(void *p) { + return + gcBYTES_TO_WORDS((sizeof(Scheme_Vector) + + ((8 - 1) * sizeof(Scheme_Object *)))); +} + +static int mark_free_id_info_MARK(void *p) { + Scheme_Vector *vec = (Scheme_Vector *)p; + int i; + for (i = 8; i--; ) + gcMARK(vec->els[i]); + + return + gcBYTES_TO_WORDS((sizeof(Scheme_Vector) + + ((8 - 1) * sizeof(Scheme_Object *)))); +} + +static int mark_free_id_info_FIXUP(void *p) { + Scheme_Vector *vec = (Scheme_Vector *)p; + int i; + for (i = 8; i--; ) + gcFIXUP(vec->els[i]); + + return + gcBYTES_TO_WORDS((sizeof(Scheme_Vector) + + ((8 - 1) * sizeof(Scheme_Object *)))); +} + +#define mark_free_id_info_IS_ATOMIC 0 +#define mark_free_id_info_IS_CONST_SIZE 0 + + + + #endif /* STXOBJ */ /**********************************************************************/ diff --git a/src/mzscheme/src/mzmarksrc.c b/src/mzscheme/src/mzmarksrc.c index d19fb7c89c..a93a9e4384 100644 --- a/src/mzscheme/src/mzmarksrc.c +++ b/src/mzscheme/src/mzmarksrc.c @@ -990,6 +990,7 @@ module_phase_exports_val { gcMARK(m->provide_src_names); gcMARK(m->provide_nominal_srcs); gcMARK(m->provide_src_phases); + gcMARK(m->provide_insps); gcMARK(m->kernel_exclusion); gcMARK(m->kernel_exclusion2); @@ -2070,7 +2071,6 @@ mark_rename_table { gcMARK(rn->nomarshal_ht); gcMARK(rn->unmarshal_info); gcMARK(rn->shared_pes); - gcMARK(rn->plus_kernel_nominal_source); gcMARK(rn->set_identity); gcMARK(rn->marked_names); gcMARK(rn->free_id_renames); @@ -2133,6 +2133,20 @@ lex_rib { gcBYTES_TO_WORDS(sizeof(Scheme_Lexical_Rib)); } +mark_free_id_info { + mark: + Scheme_Vector *vec = (Scheme_Vector *)p; + int i; + for (i = 8; i--; ) + gcMARK(vec->els[i]); + + size: + gcBYTES_TO_WORDS((sizeof(Scheme_Vector) + + ((8 - 1) * sizeof(Scheme_Object *)))); +} + + + END stxobj; /**********************************************************************/ diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 3cf8d558b9..385e3f4e9d 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -779,14 +779,14 @@ Scheme_Object* scheme_extend_module_rename(Scheme_Object *rn, Scheme_Object *mod Scheme_Object *locname, Scheme_Object *exname, Scheme_Object *nominal_src, Scheme_Object *nominal_ex, int mod_phase, Scheme_Object *src_phase_index, - Scheme_Object *nom_export_phase, int drop_for_marshal); + Scheme_Object *nom_export_phase, Scheme_Object *insp, + int mode); void scheme_extend_module_rename_with_shared(Scheme_Object *rn, Scheme_Object *modidx, struct Scheme_Module_Phase_Exports *pt, Scheme_Object *unmarshal_phase_index, Scheme_Object *src_phase_index, Scheme_Object *marks, int save_unmarshal); -void scheme_extend_module_rename_with_kernel(Scheme_Object *rn, Scheme_Object *nominal_src); void scheme_save_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info); void scheme_do_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info, Scheme_Object *modidx_shift_from, Scheme_Object *modidx_shift_to, @@ -809,7 +809,7 @@ Scheme_Object *scheme_flatten_syntax_list(Scheme_Object *lst, int *islist); int scheme_stx_module_eq(Scheme_Object *a, Scheme_Object *b, long phase); int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase, Scheme_Object *asym); Scheme_Object *scheme_stx_get_module_eq_sym(Scheme_Object *a, Scheme_Object *phase); -Scheme_Object *scheme_stx_module_name(int recur, +Scheme_Object *scheme_stx_module_name(Scheme_Hash_Table *recur, Scheme_Object **name, Scheme_Object *phase, Scheme_Object **nominal_modidx, Scheme_Object **nominal_name, @@ -817,7 +817,8 @@ Scheme_Object *scheme_stx_module_name(int recur, Scheme_Object **src_phase_index, Scheme_Object **nominal_src_phase, Scheme_Object **lex_env, - int *_sealed); + int *_sealed, + Scheme_Object **rename_insp); Scheme_Object *scheme_stx_moduleless_env(Scheme_Object *a); int scheme_stx_parallel_is_used(Scheme_Object *sym, Scheme_Object *stx); @@ -1140,7 +1141,7 @@ typedef struct Scheme_Cont_Mark_Set { Scheme_Object *native_stack_trace; } Scheme_Cont_Mark_Set; -#define SCHEME_LOG_MARK_SEGMENT_SIZE 8 +#define SCHEME_LOG_MARK_SEGMENT_SIZE 6 #define SCHEME_MARK_SEGMENT_SIZE (1 << SCHEME_LOG_MARK_SEGMENT_SIZE) #define SCHEME_MARK_SEGMENT_MASK (SCHEME_MARK_SEGMENT_SIZE - 1) @@ -2653,10 +2654,10 @@ typedef struct Scheme_Module_Phase_Exports Scheme_Object **provide_src_names; /* symbols (original internal names) */ Scheme_Object **provide_nominal_srcs; /* import source if re-exported; NULL or array of lists */ char *provide_src_phases; /* NULL, or src phase for for-syntax import */ + Scheme_Object **provide_insps; /* inspectors for re-provided protected/unexported */ int num_provides; int num_var_provides; /* non-syntax listed first in provides */ - int reprovide_kernel; /* if true, extend provides with kernel's */ Scheme_Object *kernel_exclusion; /* we allow up to two exns, but they must be shadowed */ Scheme_Object *kernel_exclusion2; @@ -2729,9 +2730,11 @@ int scheme_module_export_position(Scheme_Object *modname, Scheme_Env *env, Schem Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object *prot_insp, Scheme_Object *in_modidx, Scheme_Object *symbol, Scheme_Object *stx, - Scheme_Object *certs, Scheme_Object *unexp_insp, + Scheme_Object *certs, Scheme_Object *unexp_insp, + Scheme_Object *rename_insp, int position, int want_pos, - int *_protected, Scheme_Env *from_env); + int *_protected, int *_unexported, + Scheme_Env *from_env, int *_would_complain); Scheme_Object *scheme_module_syntax(Scheme_Object *modname, Scheme_Env *env, Scheme_Object *name); Scheme_Object *scheme_modidx_shift(Scheme_Object *modidx, diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index a58c15b25f..3f88efcb15 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "4.1.5.4" +#define MZSCHEME_VERSION "4.1.5.5" #define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_Y 1 #define MZSCHEME_VERSION_Z 5 -#define MZSCHEME_VERSION_W 4 +#define MZSCHEME_VERSION_W 5 #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/struct.c b/src/mzscheme/src/struct.c index d3f23a65ab..1c86cd4b8e 100644 --- a/src/mzscheme/src/struct.c +++ b/src/mzscheme/src/struct.c @@ -2164,19 +2164,29 @@ static Scheme_Object *make_struct_field_xxor(const char *who, int getter, pos = parse_pos(who, i, argv, argc); if (argc > 2) { - if (!SCHEME_SYMBOLP(argv[2])) { - scheme_wrong_type(who, "symbol", 2, argc, argv); - return NULL; + if (SCHEME_FALSEP(argv[2])) { + fieldstr = NULL; + fieldstrlen = 0; + } else { + if (!SCHEME_SYMBOLP(argv[2])) { + scheme_wrong_type(who, "symbol or #f", 2, argc, argv); + return NULL; + } + fieldstr = scheme_symbol_val(argv[2]); + fieldstrlen = SCHEME_SYM_LEN(argv[2]); } - fieldstr = scheme_symbol_val(argv[2]); - fieldstrlen = SCHEME_SYM_LEN(argv[2]); } else { sprintf(digitbuf, "field%d", (int)SCHEME_INT_VAL(argv[1])); fieldstr = digitbuf; fieldstrlen = strlen(fieldstr); } - if (getter) { + if (!fieldstr) { + if (getter) + name = "accessor"; + else + name = "mutator"; + } else if (getter) { name = (char *)GET_NAME((char *)i->struct_type->name, -1, fieldstr, fieldstrlen, 0); } else { diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index 2792830328..a012173ea4 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -71,6 +71,9 @@ static Scheme_Object *syntax_recertify(int argc, Scheme_Object **argv); static Scheme_Object *lift_inactive_certs(Scheme_Object *o, int as_active); +static Scheme_Object *write_free_id_info_prefix(Scheme_Object *obj); +static Scheme_Object *read_free_id_info_prefix(Scheme_Object *obj); + static Scheme_Object *source_symbol; /* uninterned! */ static Scheme_Object *share_symbol; /* uninterned! */ static Scheme_Object *origin_symbol; @@ -88,6 +91,7 @@ static Scheme_Stx_Srcloc *empty_srcloc; static Scheme_Object *empty_simplified; static Scheme_Hash_Table *empty_hash_table; +static THREAD_LOCAL Scheme_Hash_Table *quick_hash_table; static THREAD_LOCAL Scheme_Object *last_phase_shift; @@ -129,16 +133,16 @@ XFORM_NONGCING static int prefab_p(Scheme_Object *o) typedef struct Module_Renames { Scheme_Object so; /* scheme_rename_table_type */ - char plus_kernel, kind, needs_unmarshal; + char kind, needs_unmarshal; char sealed; /* 1 means bound won't change; 2 means unbound won't change, either */ Scheme_Object *phase; - Scheme_Object *plus_kernel_nominal_source; Scheme_Object *set_identity; Scheme_Hash_Table *ht; /* localname -> modidx OR (cons modidx exportname) OR (cons modidx nominal_modidx) OR (list* modidx exportname nominal_modidx_plus_phase nominal_exportname) OR - (list* modidx mod-phase exportname nominal_modidx_plus_phase nominal_exportname) + (list* modidx mod-phase exportname nominal_modidx_plus_phase nominal_exportname) OR + (cons insp localname) nominal_modix_plus_phase -> nominal_modix | (cons nominal_modix import_phase_plus_nominal_phase) import_phase_plus_nominal_phase -> import-phase-index | (cons import-phase-index nom-phase) */ Scheme_Hash_Table *nomarshal_ht; /* like ht, but dropped on marshal */ @@ -217,6 +221,14 @@ static Module_Renames *krn; #define SCHEME_MODIDXP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_module_index_type)) +static int is_rename_inspector_info(Scheme_Object *v) +{ + return (SAME_TYPE(SCHEME_TYPE(v), scheme_inspector_type) + || (SCHEME_PAIRP(v) + && SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(v)), scheme_inspector_type) + && SAME_TYPE(SCHEME_TYPE(SCHEME_CDR(v)), scheme_inspector_type))); +} + /* Wraps: A wrap is a list of wrap-elems and wrap-chunks. A wrap-chunk is a @@ -241,11 +253,11 @@ static Module_Renames *krn; (cons (cons )) => free-id=? renaming to on match - A wrap-elem (vector ... ...) is also a lexical rename - var resolved: sym or (cons ), - where is module/lexical binding info: - (cons #f) => top-level binding - (cons ) => lexical binding - (vector ...) => module-binding + bool var resolved: sym or (cons ), + where is module/lexical binding info: + (cons #f) => top-level binding + (cons ) => lexical binding + (free-eq-info ...) => module-binding where the variables have already been resolved and filtered (no mark or lexical-env comparison needed with the remaining wraps) @@ -570,6 +582,8 @@ void scheme_init_stx(Scheme_Env *env) REGISTER_SO(nominal_ipair_cache); + REGISTER_SO(quick_hash_table); + REGISTER_SO(last_phase_shift); REGISTER_SO(empty_hash_table); @@ -583,6 +597,9 @@ void scheme_init_stx(Scheme_Env *env) SCHEME_SET_IMMUTABLE(no_nested_inactive_certs); REGISTER_SO(unsealed_dependencies); + + scheme_install_type_writer(scheme_free_id_info_type, write_free_id_info_prefix); + scheme_install_type_reader(scheme_free_id_info_type, read_free_id_info_prefix); } /*========================================================================*/ @@ -1352,15 +1369,6 @@ static void check_not_sealed(Module_Renames *mrn) scheme_signal_error("internal error: attempt to change sealed module rename"); } -void scheme_extend_module_rename_with_kernel(Scheme_Object *mrn, Scheme_Object *nominal_mod) -{ - /* Don't use on a non-module namespace, where renames may need - to be removed... */ - check_not_sealed((Module_Renames *)mrn); - ((Module_Renames *)mrn)->plus_kernel = 1; - ((Module_Renames *)mrn)->plus_kernel_nominal_source = nominal_mod; -} - static Scheme_Object *phase_to_index(Scheme_Object *phase) { return phase; @@ -1375,6 +1383,7 @@ Scheme_Object *scheme_extend_module_rename(Scheme_Object *mrn, int mod_phase, /* phase of source defn */ Scheme_Object *src_phase_index, /* nominal import phase */ Scheme_Object *nom_phase, /* nominal export phase */ + Scheme_Object *insp, /* inspector for re-export */ int mode) /* 1 => can be reconstructed from unmarshal info 2 => free-id=? renaming 3 => return info */ @@ -1429,6 +1438,9 @@ Scheme_Object *scheme_extend_module_rename(Scheme_Object *mrn, elem = CONS(scheme_make_integer(mod_phase), elem); elem = CONS(modname, elem); } + + if (insp) + elem = CONS(insp, elem); if (mode == 1) { if (!((Module_Renames *)mrn)->nomarshal_ht) { @@ -1497,11 +1509,6 @@ static void do_append_module_rename(Scheme_Object *src, Scheme_Object *dest, check_not_sealed((Module_Renames *)dest); - if (((Module_Renames *)src)->plus_kernel) { - ((Module_Renames *)dest)->plus_kernel = 1; - ((Module_Renames *)dest)->plus_kernel_nominal_source = ((Module_Renames *)src)->plus_kernel_nominal_source; - } - if (do_pes) { if (!SCHEME_NULLP(((Module_Renames *)src)->shared_pes)) { Scheme_Object *first = NULL, *last = NULL, *pr, *l; @@ -1559,6 +1566,14 @@ static void do_append_module_rename(Scheme_Object *src, Scheme_Object *dest, if (hts->vals[i]) { v = hts->vals[i]; if (old_midx) { + Scheme_Object *insp = NULL; + + if (SCHEME_PAIRP(v) && is_rename_inspector_info(SCHEME_CAR(v))) { + insp = SCHEME_CAR(v); + v = SCHEME_CDR(v); + } else + insp = NULL; + /* Shift the modidx part */ if (SCHEME_PAIRP(v)) { if (SCHEME_PAIRP(SCHEME_CDR(v))) { @@ -1597,6 +1612,9 @@ static void do_append_module_rename(Scheme_Object *src, Scheme_Object *dest, /* modidx */ v = scheme_modidx_shift(v, old_midx, new_midx); } + + if (insp) + v = CONS(insp, v); } scheme_hash_set(ht, hts->keys[i], v); if (drop_ht) @@ -1698,12 +1716,6 @@ void scheme_list_module_rename(Scheme_Object *set, Scheme_Hash_Table *ht) for (i = pt->num_provides; i--; ) { scheme_hash_set(ht, pt->provides[i], scheme_false); } - if (pt->reprovide_kernel) - scheme_list_module_rename((Scheme_Object *)krn, ht); - } - - if (src->plus_kernel) { - scheme_list_module_rename((Scheme_Object *)krn, ht); } } @@ -1930,10 +1942,29 @@ Scheme_Object *scheme_add_rename_rib(Scheme_Object *o, Scheme_Object *rib) return scheme_add_rename(o, rib); } +static Scheme_Hash_Table *make_recur_table() +{ + if (quick_hash_table) { + GC_CAN_IGNORE Scheme_Hash_Table *t; + t = quick_hash_table; + quick_hash_table = NULL; + return t; + } else + return scheme_make_hash_table(SCHEME_hash_ptr); +} + +static void release_recur_table(Scheme_Hash_Table *free_id_recur) +{ + if (!free_id_recur->size && !quick_hash_table) { + quick_hash_table = free_id_recur; + } +} + static Scheme_Object *extract_module_free_id_binding(Scheme_Object *mrn, Scheme_Object *id, Scheme_Object *orig_id, - int *_sealed) + int *_sealed, + Scheme_Hash_Table *free_id_recur) { Scheme_Object *result; Scheme_Object *modname; @@ -1943,17 +1974,24 @@ static Scheme_Object *extract_module_free_id_binding(Scheme_Object *mrn, Scheme_Object *src_phase_index; Scheme_Object *nominal_src_phase; Scheme_Object *lex_env; + Scheme_Object *rename_insp; + + if (scheme_hash_get(free_id_recur, id)) { + return id; + } + scheme_hash_set(free_id_recur, id, id); nom2 = scheme_stx_property(orig_id, nominal_id_symbol, NULL); - modname = scheme_stx_module_name(1, + modname = scheme_stx_module_name(free_id_recur, &orig_id, ((Module_Renames *)mrn)->phase, &nominal_modidx, &nominal_name, &mod_phase, &src_phase_index, &nominal_src_phase, &lex_env, - _sealed); + _sealed, + &rename_insp); if (SCHEME_SYMBOLP(nom2)) nominal_name = nom2; @@ -1972,6 +2010,7 @@ static Scheme_Object *extract_module_free_id_binding(Scheme_Object *mrn, SCHEME_INT_VAL(mod_phase), /* phase of source defn */ src_phase_index, /* nominal import phase */ nominal_src_phase, /* nominal export phase */ + rename_insp, 3); if (*_sealed) { @@ -3683,7 +3722,7 @@ static Scheme_Object *search_shared_pes(Scheme_Object *shared_pes, Scheme_Object *pr, *idx, *pos, *src, *best_match = NULL; Scheme_Module_Phase_Exports *pt; Scheme_Hash_Table *ht; - int i, phase, best_match_len = -1, skip; + int i, phase, best_match_len = -1, skip = 0; Scheme_Object *marks_cache = NULL; for (pr = shared_pes; !SCHEME_NULLP(pr); pr = SCHEME_CDR(pr)) { @@ -3744,6 +3783,7 @@ static Scheme_Object *search_shared_pes(Scheme_Object *shared_pes, if (SCHEME_PAIRP(get_names[4])) /* skip over marks, if any */ get_names[4] = SCHEME_CDR(get_names[4]); get_names[5] = pt->phase_index; + get_names[6] = (pt->provide_insps ? pt->provide_insps[i] : NULL); } if (SCHEME_FALSEP(src)) { @@ -3755,34 +3795,6 @@ static Scheme_Object *search_shared_pes(Scheme_Object *shared_pes, best_match = src; } } - } else if (pt->reprovide_kernel) { - Scheme_Object *kpr; - kpr = scheme_hash_get(krn->ht, glob_id); - if (kpr) { - /* Found it, maybe. Check marks. */ - int mark_len, skip; - mark_len = check_matching_marks(SCHEME_CAR(pr), orig_id, &marks_cache, depth, &skip); - if (mark_len > best_match_len) { - /* Marks match and improve on previously found match. Build suitable rename: */ - best_match_len = mark_len; - if (_skipped) *_skipped = skip; - - if (get_orig_name) - best_match = glob_id; - else { - if (get_names) { - idx = SCHEME_CAR(SCHEME_CAR(kpr)); - get_names[0] = glob_id; - get_names[1] = idx; - get_names[2] = glob_id; - get_names[3] = scheme_make_integer(0); - get_names[4] = pt->phase_index; - get_names[5] = scheme_make_integer(0); - } - best_match = scheme_get_kernel_modidx(); - } - } - } } } @@ -3939,13 +3951,16 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, Scheme_Object *a, Scheme_Object *orig_phase, int w_mod, Scheme_Object **get_names, Scheme_Object *skip_ribs, int *_binding_marks_skipped, - int *_depends_on_unsealed_rib, int depth, int get_free_id_info) + int *_depends_on_unsealed_rib, int depth, + Scheme_Hash_Table *free_id_recur) /* Module binding ignored if w_mod is 0. If module bound, result is module idx, and get_names[0] is set to source name, get_names[1] is set to the nominal source module, get_names[2] is set to the nominal source module's export, get_names[3] is set to the phase of the source definition, and get_names[4] is set to the nominal import phase index, - and get_names[5] is set to the nominal export phase. + and get_names[5] is set to the nominal export phase; get_names[6] is set to + an inspector/pair if one applies for a re-export of a protected or unexported, NULL or + #f otherwise. If lexically bound, result is env id, and a get_names[0] is set to scheme_undefined; get_names[1] is set if a free-id=? rename provides a different name for the bindig. If neither, result is #f and get_names[0] is either unchanged or NULL; get_names[1] @@ -3953,7 +3968,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, { WRAP_POS wraps; Scheme_Object *o_rename_stack = scheme_null, *recur_skip_ribs = skip_ribs; - Scheme_Object *mresult = scheme_false; + Scheme_Object *mresult = scheme_false, *mresult_insp; Scheme_Object *modidx_shift_to = NULL, *modidx_shift_from = NULL; Scheme_Object *rename_stack[QUICK_STACK_SIZE]; int stack_pos = 0, no_lexical = 0; @@ -4024,7 +4039,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, if (mresult_depends_unsealed) depends_on_unsealed_rib = 1; } else { - if (get_free_id_info && !SCHEME_VOIDP(result_free_rename)) { + if (free_id_recur && !SCHEME_VOIDP(result_free_rename)) { Scheme_Object *orig; int rib_dep = 0; orig = result_free_rename; @@ -4035,10 +4050,14 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, phase = scheme_bin_plus(phase, SCHEME_VEC_ELS(orig)[1]); if (get_names) get_names[1] = NULL; - result = resolve_env(NULL, SCHEME_CAR(result_free_rename), phase, - w_mod, get_names, - NULL, _binding_marks_skipped, - &rib_dep, depth + 1, 1); + result = SCHEME_CAR(result_free_rename); + if (!scheme_hash_get(free_id_recur, result)) { + scheme_hash_set(free_id_recur, result, scheme_true); + result = resolve_env(NULL, result, phase, + w_mod, get_names, + NULL, _binding_marks_skipped, + &rib_dep, depth + 1, free_id_recur); + } if (get_names && !get_names[1]) if (SCHEME_FALSEP(result) || SAME_OBJ(scheme_undefined, get_names[0])) get_names[1] = SCHEME_STX_VAL(SCHEME_CAR(result_free_rename)); @@ -4048,7 +4067,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, result = SCHEME_CDR(result_free_rename); if (get_names) get_names[0] = scheme_undefined; - } else if (SCHEME_VECTORP(result_free_rename)) { + } else if (SAME_OBJ(SCHEME_TYPE(result_free_rename), scheme_free_id_info_type)) { result = SCHEME_VEC_ELS(result_free_rename)[0]; if (get_names) { get_names[0] = SCHEME_VEC_ELS(result_free_rename)[1]; @@ -4057,6 +4076,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, get_names[3] = SCHEME_VEC_ELS(result_free_rename)[4]; get_names[4] = SCHEME_VEC_ELS(result_free_rename)[5]; get_names[5] = SCHEME_VEC_ELS(result_free_rename)[6]; + get_names[6] = SCHEME_VEC_ELS(result_free_rename)[7]; } } else { if (get_names) @@ -4123,7 +4143,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, EXPLAIN(fprintf(stderr, "%d tl_id_sym\n", depth)); if (!bdg) { EXPLAIN(fprintf(stderr, "%d get bdg\n", depth)); - bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, recur_skip_ribs, NULL, NULL, depth+1, 0); + bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, recur_skip_ribs, NULL, NULL, depth+1, NULL); if (SCHEME_FALSEP(bdg)) { if (!floating_checked) { floating = check_floating_id(a); @@ -4153,14 +4173,15 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, EXPLAIN(fprintf(stderr, "%d search %s\n", depth, scheme_write_to_string(glob_id, 0))); - if (get_free_id_info && mrn->free_id_renames) { + if (free_id_recur && mrn->free_id_renames) { rename = scheme_hash_get(mrn->free_id_renames, glob_id); if (rename && SCHEME_STXP(rename)) { int sealed; rename = extract_module_free_id_binding((Scheme_Object *)mrn, glob_id, rename, - &sealed); + &sealed, + free_id_recur); if (!sealed) mresult_depends_unsealed = 1; } @@ -4170,10 +4191,6 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, rename = scheme_hash_get(mrn->ht, glob_id); if (!rename && mrn->nomarshal_ht) rename = scheme_hash_get(mrn->nomarshal_ht, glob_id); - if (!rename && mrn->plus_kernel) { - rename = scheme_hash_get(krn->ht, glob_id); - nominal = mrn->plus_kernel_nominal_source; - } get_names_done = 0; if (!rename) { EXPLAIN(fprintf(stderr, "%d in pes\n", depth)); @@ -4198,6 +4215,8 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, /* match; set mresult, which is used in the case of no lexical capture: */ mresult_skipped = skipped; + + mresult_insp = NULL; if (SCHEME_BOXP(rename)) { /* This should only happen for mappings from free_id_renames */ @@ -4211,9 +4230,14 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, } mresult = SCHEME_CDR(mresult); } else { - if (SCHEME_PAIRP(rename)) + if (SCHEME_PAIRP(rename)) { mresult = SCHEME_CAR(rename); - else + if (is_rename_inspector_info(mresult)) { + mresult_insp = mresult; + rename = SCHEME_CDR(rename); + mresult = SCHEME_CAR(rename); + } + } else mresult = rename; if (modidx_shift_from) @@ -4281,6 +4305,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, if (!get_names[5]) { get_names[5] = get_names[3]; } + get_names[6] = mresult_insp; } if (modidx_shift_from && !no_shift) { @@ -4416,7 +4441,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, if (SCHEME_VOIDP(other_env)) { int rib_dep = 0; SCHEME_USE_FUEL(1); - other_env = resolve_env(NULL, renamed, 0, 0, NULL, recur_skip_ribs, NULL, &rib_dep, depth+1, 0); + other_env = resolve_env(NULL, renamed, 0, 0, NULL, recur_skip_ribs, NULL, &rib_dep, depth+1, NULL); { Scheme_Object *e; e = extend_cached_env(SCHEME_VEC_ELS(rename)[2+c+ri], other_env, recur_skip_ribs, @@ -4449,7 +4474,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, top element of the stack and combine the two mappings, but the intermediate name may be needed (for other_env values that don't come from this stack). */ - if (get_free_id_info && !SCHEME_VOIDP(free_id_rename)) { + if (free_id_recur && !SCHEME_VOIDP(free_id_rename)) { /* Need to remember phase ad shifts for free-id=? rename: */ Scheme_Object *vec; vec = scheme_make_vector(4, NULL); @@ -4535,7 +4560,8 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, } } -static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_phase, int use_free_id_renames) +static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_phase, + Scheme_Hash_Table *free_id_recur) /* Gets a module source name under the assumption that the identifier is not lexically renamed. This is used as a quick pre-test for free-identifier=?. We do have to look at lexical renames to check for @@ -4545,11 +4571,11 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ WRAP_POS wraps; Scheme_Object *result, *result_from; int is_in_module = 0, skip_other_mods = 0, sealed = STX_SEAL_ALL, floating_checked = 0; - int no_lexical = !use_free_id_renames; + int no_lexical = !free_id_recur; Scheme_Object *phase = orig_phase; Scheme_Object *bdg = NULL, *floating = NULL; - if (!use_free_id_renames + if (!free_id_recur && SAME_OBJ(phase, scheme_make_integer(0)) && ((Scheme_Stx *)a)->u.modinfo_cache) return ((Scheme_Stx *)a)->u.modinfo_cache; @@ -4568,7 +4594,7 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ if (!result) result = SCHEME_STX_VAL(a); - if (can_cache && SAME_OBJ(orig_phase, scheme_make_integer(0)) && !use_free_id_renames) + if (can_cache && SAME_OBJ(orig_phase, scheme_make_integer(0)) && !free_id_recur) ((Scheme_Stx *)a)->u.modinfo_cache = result; return result; @@ -4609,13 +4635,13 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ if (mrn->needs_unmarshal) { /* Use resolve_env to trigger unmarshal, so that we don't have to implement top/from shifts here: */ - resolve_env(NULL, a, orig_phase, 1, NULL, NULL, NULL, NULL, 0, 0); + resolve_env(NULL, a, orig_phase, 1, NULL, NULL, NULL, NULL, 0, NULL); } if (mrn->marked_names) { /* Resolve based on rest of wraps: */ if (!bdg) - bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, NULL, NULL, NULL, 0, 0); + bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, NULL, NULL, NULL, 0, NULL); if (SCHEME_FALSEP(bdg)) { if (!floating_checked) { floating = check_floating_id(a); @@ -4634,14 +4660,15 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ } else glob_id = SCHEME_STX_VAL(a); - if (use_free_id_renames && mrn->free_id_renames) { + if (free_id_recur && mrn->free_id_renames) { rename = scheme_hash_get(mrn->free_id_renames, glob_id); if (rename && SCHEME_STXP(rename)) { int sealed; rename = extract_module_free_id_binding((Scheme_Object *)mrn, glob_id, rename, - &sealed); + &sealed, + free_id_recur); if (!sealed) sealed = 0; } @@ -4651,8 +4678,6 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ rename = scheme_hash_get(mrn->ht, glob_id); if (!rename && mrn->nomarshal_ht) rename = scheme_hash_get(mrn->nomarshal_ht, glob_id); - if (!rename && mrn->plus_kernel) - rename = scheme_hash_get(krn->ht, glob_id); if (!rename) result = search_shared_pes(mrn->shared_pes, glob_id, a, NULL, 1, 0, NULL); @@ -4745,7 +4770,7 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ if (SCHEME_PAIRP(renames)) { /* Has a relevant-looking free-id mapping. Give up on the "fast" traversal. */ - Scheme_Object *modname, *names[6]; + Scheme_Object *modname, *names[7]; int rib_dep; names[0] = NULL; @@ -4753,8 +4778,9 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ names[3] = scheme_make_integer(0); names[4] = NULL; names[5] = NULL; + names[6] = NULL; - modname = resolve_env(NULL, a, orig_phase, 1, names, NULL, NULL, &rib_dep, 0, 1); + modname = resolve_env(NULL, a, orig_phase, 1, names, NULL, NULL, &rib_dep, 0, free_id_recur); if (rib_dep) sealed = 0; @@ -4784,18 +4810,27 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase, Scheme_Object *asym) { Scheme_Object *bsym; + Scheme_Hash_Table *free_id_recur; if (!a || !b) return (a == b); - if (SCHEME_STXP(b)) - bsym = get_module_src_name(b, phase, !asym); - else + if (SCHEME_STXP(b)) { + if (!asym) + free_id_recur = make_recur_table(); + else + free_id_recur = NULL; + bsym = get_module_src_name(b, phase, free_id_recur); + if (!asym) + release_recur_table(free_id_recur); + } else bsym = b; if (!asym) { - if (SCHEME_STXP(a)) - asym = get_module_src_name(a, phase, 1); - else + if (SCHEME_STXP(a)) { + free_id_recur = make_recur_table(); + asym = get_module_src_name(a, phase, free_id_recur); + release_recur_table(free_id_recur); + } else asym = a; } @@ -4805,9 +4840,14 @@ int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *pha if ((a == asym) || (b == bsym)) return 1; - - a = resolve_env(NULL, a, phase, 1, NULL, NULL, NULL, NULL, 0, 1); - b = resolve_env(NULL, b, phase, 1, NULL, NULL, NULL, NULL, 0, 1); + + free_id_recur = make_recur_table(); + a = resolve_env(NULL, a, phase, 1, NULL, NULL, NULL, NULL, 0, free_id_recur); + release_recur_table(free_id_recur); + + free_id_recur = make_recur_table(); + b = resolve_env(NULL, b, phase, 1, NULL, NULL, NULL, NULL, 0, free_id_recur); + release_recur_table(free_id_recur); if (SAME_TYPE(SCHEME_TYPE(a), scheme_module_index_type)) a = scheme_module_resolve(a, 0); @@ -4826,12 +4866,12 @@ int scheme_stx_module_eq(Scheme_Object *a, Scheme_Object *b, long phase) Scheme_Object *scheme_stx_get_module_eq_sym(Scheme_Object *a, Scheme_Object *phase) { if (SCHEME_STXP(a)) - return get_module_src_name(a, phase, 0); + return get_module_src_name(a, phase, NULL); else return a; } -Scheme_Object *scheme_stx_module_name(int recur, +Scheme_Object *scheme_stx_module_name(Scheme_Hash_Table *free_id_recur, Scheme_Object **a, Scheme_Object *phase, Scheme_Object **nominal_modidx, /* how it was imported */ Scheme_Object **nominal_name, /* imported as name */ @@ -4839,7 +4879,8 @@ Scheme_Object *scheme_stx_module_name(int recur, Scheme_Object **src_phase_index, /* phase level of import from nominal modidx */ Scheme_Object **nominal_src_phase, /* phase level of export from nominal modidx */ Scheme_Object **lex_env, - int *_sealed) + int *_sealed, + Scheme_Object **insp) /* If module bound, result is module idx, and a is set to source name. If lexically bound, result is scheme_undefined, a is unchanged, and nominal_name is NULL or a free_id=? renamed id. @@ -4847,7 +4888,7 @@ Scheme_Object *scheme_stx_module_name(int recur, and nominal_name is NULL or a free_id=? renamed id. */ { if (SCHEME_STXP(*a)) { - Scheme_Object *modname, *names[6]; + Scheme_Object *modname, *names[7]; int rib_dep; names[0] = NULL; @@ -4855,8 +4896,9 @@ Scheme_Object *scheme_stx_module_name(int recur, names[3] = scheme_make_integer(0); names[4] = NULL; names[5] = NULL; + names[6] = NULL; - modname = resolve_env(NULL, *a, phase, 1, names, NULL, NULL, _sealed ? &rib_dep : NULL, 0, recur); + modname = resolve_env(NULL, *a, phase, 1, names, NULL, NULL, _sealed ? &rib_dep : NULL, 0, free_id_recur); if (_sealed) *_sealed = !rib_dep; @@ -4879,6 +4921,8 @@ Scheme_Object *scheme_stx_module_name(int recur, *src_phase_index = names[4]; if (nominal_src_phase) *nominal_src_phase = names[5]; + if (insp) + *insp = names[6]; return modname; } } else { @@ -4902,8 +4946,8 @@ int scheme_stx_ribs_matter(Scheme_Object *a, Scheme_Object *skip_ribs) skip_ribs = SCHEME_CDR(skip_ribs); } - m1 = resolve_env(NULL, a, scheme_make_integer(0), 1, NULL, NULL, NULL, NULL, 0, 0); - m2 = resolve_env(NULL, a, scheme_make_integer(0), 1, NULL, skips, NULL, NULL, 0, 0); + m1 = resolve_env(NULL, a, scheme_make_integer(0), 1, NULL, NULL, NULL, NULL, 0, NULL); + m2 = resolve_env(NULL, a, scheme_make_integer(0), 1, NULL, skips, NULL, NULL, 0, NULL); return !SAME_OBJ(m1, m2); } @@ -4914,7 +4958,7 @@ Scheme_Object *scheme_stx_moduleless_env(Scheme_Object *a) if (SCHEME_STXP(a)) { Scheme_Object *r; - r = resolve_env(NULL, a, scheme_make_integer(0), 0, NULL, NULL, NULL, NULL, 0, 0); + r = resolve_env(NULL, a, scheme_make_integer(0), 0, NULL, NULL, NULL, NULL, 0, NULL); if (SCHEME_FALSEP(r)) r = check_floating_id(a); @@ -4946,13 +4990,13 @@ int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *u if (!SAME_OBJ(asym, bsym)) return 0; - ae = resolve_env(NULL, a, phase, 0, NULL, NULL, NULL, NULL, 0, 0); + ae = resolve_env(NULL, a, phase, 0, NULL, NULL, NULL, NULL, 0, NULL); /* No need to module_resolve ae, because we ignored module renamings. */ if (uid) be = uid; else { - be = resolve_env(NULL, b, phase, 0, NULL, NULL, NULL, NULL, 0, 0); + be = resolve_env(NULL, b, phase, 0, NULL, NULL, NULL, NULL, 0, NULL); /* No need to module_resolve be, because we ignored module renamings. */ } @@ -4982,7 +5026,7 @@ int scheme_stx_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase Scheme_Object *scheme_explain_resolve_env(Scheme_Object *a) { scheme_explain_resolves++; - a = resolve_env(NULL, a, 0, 0, NULL, NULL, NULL, NULL, 0, 1); + a = resolve_env(NULL, a, 0, 0, NULL, NULL, NULL, NULL, 0, NULL); --scheme_explain_resolves; return a; } @@ -5378,17 +5422,20 @@ static Scheme_Object *extract_free_id_info(Scheme_Object *id) Scheme_Object *src_phase_index; Scheme_Object *nominal_src_phase; Scheme_Object *lex_env = NULL; - Scheme_Object *vec, *phase; + Scheme_Object *vec, *phase, *insp; + Scheme_Hash_Table *free_id_recur; phase = SCHEME_CDR(id); id = SCHEME_CAR(id); nom2 = scheme_stx_property(id, nominal_id_symbol, NULL); - bind = scheme_stx_module_name(1, + free_id_recur = make_recur_table(); + bind = scheme_stx_module_name(free_id_recur, &id, phase, &nominal_modidx, &nominal_name, &mod_phase, &src_phase_index, &nominal_src_phase, - &lex_env, NULL); + &lex_env, NULL, &insp); + release_recur_table(free_id_recur); if (SCHEME_SYMBOLP(nom2)) nominal_name = nom2; @@ -5400,7 +5447,8 @@ static Scheme_Object *extract_free_id_info(Scheme_Object *id) else if (SAME_OBJ(bind, scheme_undefined)) return CONS(nominal_name, lex_env); else { - vec = scheme_make_vector(7, NULL); + vec = scheme_make_vector(8, NULL); + vec->type = scheme_free_id_info_type; SCHEME_VEC_ELS(vec)[0] = bind; SCHEME_VEC_ELS(vec)[1] = id; SCHEME_VEC_ELS(vec)[2] = nominal_modidx; @@ -5408,6 +5456,7 @@ static Scheme_Object *extract_free_id_info(Scheme_Object *id) SCHEME_VEC_ELS(vec)[4] = mod_phase; SCHEME_VEC_ELS(vec)[5] = src_phase_index; SCHEME_VEC_ELS(vec)[6] = nominal_src_phase; + SCHEME_VEC_ELS(vec)[7] = (insp ? insp : scheme_false); return vec; } } @@ -5534,7 +5583,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab other_env = filter_cached_env(other_env, prec_ribs); if (SCHEME_VOIDP(other_env)) { int rib_dep; - other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0, 0); + other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0, NULL); if (rib_dep) { scheme_signal_error("compile: unsealed local-definition context found in fully expanded form"); return NULL; @@ -5707,7 +5756,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab other_env = filter_cached_env(other_env, prec_ribs); if (SCHEME_VOIDP(other_env)) { int rib_dep; - other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0, 0); + other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0, NULL); if (rib_dep) { scheme_signal_error("compile: unsealed local-definition context found in fully expanded form"); return NULL; @@ -6119,15 +6168,16 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, if (mrn->free_id_renames->vals[i]) { if (SCHEME_STXP(mrn->free_id_renames->vals[i])) { int sealed; + Scheme_Hash_Table *free_id_recur; + + free_id_recur = make_recur_table(); b = extract_module_free_id_binding((Scheme_Object *)mrn, mrn->free_id_renames->keys[i], mrn->free_id_renames->vals[i], - &sealed); + &sealed, + free_id_recur); + release_recur_table(free_id_recur); if (!sealed) { - extract_module_free_id_binding((Scheme_Object *)mrn, - mrn->free_id_renames->keys[i], - mrn->free_id_renames->vals[i], - &sealed); scheme_signal_error("write: unsealed local-definition or module context" " found in syntax object"); } @@ -6158,7 +6208,15 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, for (i = ht->size, j = 0; i--; ) { if (ht->vals[i]) { SCHEME_VEC_ELS(l)[j++] = ht->keys[i]; - SCHEME_VEC_ELS(l)[j++] = ht->vals[i]; + fil = ht->vals[i]; + if (SCHEME_PAIRP(fil) && is_rename_inspector_info(SCHEME_CAR(fil))) { + /* use 1 or 2 to indicate inspector info */ + if (SCHEME_PAIRP(SCHEME_CAR(fil))) + fil = CONS(scheme_make_integer(2), SCHEME_CDR(fil)); + else + fil = CONS(scheme_make_integer(1), SCHEME_CDR(fil)); + } + SCHEME_VEC_ELS(l)[j++] = fil; } } @@ -6205,10 +6263,6 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, l = CONS(mrn->set_identity, l); l = CONS((mrn->kind == mzMOD_RENAME_MARKED) ? scheme_true : scheme_false, l); l = CONS(mrn->phase, l); - if (mrn->plus_kernel) { - l = CONS(scheme_true,l); - /* FIXME: plus-kernel nominal omitted */ - } local_key = scheme_marshal_lookup(mt, a); if (local_key) @@ -6731,7 +6785,7 @@ static int ok_phase_index(Scheme_Object *o) { static Scheme_Object *datum_to_module_renames(Scheme_Object *a, Scheme_Hash_Table *ht, int lex_ok) { int count, i; - Scheme_Object *key, *p; + Scheme_Object *key, *p0, *p; if (!SCHEME_VECTORP(a)) return_NULL; count = SCHEME_VEC_SIZE(a); @@ -6739,10 +6793,22 @@ static Scheme_Object *datum_to_module_renames(Scheme_Object *a, Scheme_Hash_Tabl for (i = 0; i < count; i+= 2) { key = SCHEME_VEC_ELS(a)[i]; - p = SCHEME_VEC_ELS(a)[i+1]; + p0 = SCHEME_VEC_ELS(a)[i+1]; if (!SCHEME_SYMBOLP(key)) return_NULL; + p = p0; + if (SCHEME_PAIRP(p) && SCHEME_INTP(SCHEME_CAR(p))) { + /* reconstruct inspector info */ + Scheme_Object *insp; + insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); + if (!SAME_OBJ(scheme_make_integer(1), SCHEME_CAR(p))) { + insp = CONS(scheme_make_inspector(insp), insp); + } + p = SCHEME_CDR(p0); + p0 = CONS(insp, p); + } + if (SAME_TYPE(SCHEME_TYPE(p), scheme_module_index_type)) { /* Ok */ } else if (SCHEME_PAIRP(p)) { @@ -6816,7 +6882,7 @@ static Scheme_Object *datum_to_module_renames(Scheme_Object *a, Scheme_Hash_Tabl } else return_NULL; - scheme_hash_set(ht, key, p); + scheme_hash_set(ht, key, p0); } return scheme_true; @@ -6910,9 +6976,7 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w, v = SCHEME_CDR(v); if (!SCHEME_SYMBOLP(v) && !SCHEME_FALSEP(v)) return_NULL; - } else if (SCHEME_VECTORP(v)) { - if (SCHEME_VEC_SIZE(v) != 7) - return_NULL; + } else if (SAME_TYPE(SCHEME_TYPE(v), scheme_free_id_info_type)) { if (!SCHEME_MODIDXP(SCHEME_VEC_ELS(v)[0]) || !SCHEME_SYMBOLP(SCHEME_VEC_ELS(v)[1]) || !SCHEME_MODIDXP(SCHEME_VEC_ELS(v)[2]) @@ -6947,7 +7011,7 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w, Scheme_Object *mns; Module_Renames *mrn; Scheme_Object *p, *key; - int plus_kernel, kind; + int kind; Scheme_Object *phase, *set_identity; if (!SCHEME_PAIRP(a)) return_NULL; @@ -6955,10 +7019,8 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w, /* Convert list to rename table: */ if (SAME_OBJ(SCHEME_CAR(a), scheme_true)) { - plus_kernel = 1; - a = SCHEME_CDR(a); - } else - plus_kernel = 0; + scheme_signal_error("leftover plus-kernel"); + } if (!SCHEME_PAIRP(a)) return_NULL; phase = SCHEME_CAR(a); @@ -6978,7 +7040,6 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w, a = SCHEME_CDR(a); mrn = (Module_Renames *)scheme_make_module_rename(phase, kind, NULL); - mrn->plus_kernel = plus_kernel; mrn->set_identity = set_identity; if (!SCHEME_PAIRP(a)) return_NULL; @@ -7800,7 +7861,7 @@ void scheme_simplify_stx(Scheme_Object *stx, Scheme_Object *cache) if (SAME_OBJ(scheme_intern_symbol("y"), SCHEME_STX_VAL(stx))) { fprintf(stderr, "simplifying... %s\n", - scheme_write_to_string(resolve_env(NULL, stx, 0, 0, NULL, NULL, NULL, NULL, 0, 0), + scheme_write_to_string(resolve_env(NULL, stx, 0, 0, NULL, NULL, NULL, NULL, 0, NULL), NULL)); explain_simp = 1; } @@ -7818,7 +7879,7 @@ void scheme_simplify_stx(Scheme_Object *stx, Scheme_Object *cache) if (explain_simp) { explain_simp = 0; fprintf(stderr, "simplified: %s\n", - scheme_write_to_string(resolve_env(NULL, stx, 0, 0, NULL, NULL, NULL, NULL, 0, 0), + scheme_write_to_string(resolve_env(NULL, stx, 0, 0, NULL, NULL, NULL, NULL, 0, NULL), NULL)); } #endif @@ -8310,7 +8371,8 @@ Scheme_Object *scheme_syntax_make_transfer_intro(int argc, Scheme_Object **argv) int skipped = -1; Scheme_Object *mod; - mod = resolve_env(NULL, argv[0], phase, 1, NULL, NULL, &skipped, NULL, 0, 1); + mod = resolve_env(NULL, argv[0], phase, 1, NULL, NULL, &skipped, NULL, 0, + scheme_make_hash_table(SCHEME_hash_ptr)); if ((skipped == -1) && SCHEME_FALSEP(mod)) { /* For top-level bindings, need to check the current environment's table, @@ -8436,7 +8498,7 @@ static Scheme_Object *do_module_binding(char *name, int argc, Scheme_Object **ar phase = scheme_bin_plus(dphase, phase); } - m = scheme_stx_module_name(1, + m = scheme_stx_module_name(scheme_make_hash_table(SCHEME_hash_ptr), &a, phase, &nom_mod, &nom_a, @@ -8444,6 +8506,7 @@ static Scheme_Object *do_module_binding(char *name, int argc, Scheme_Object **ar &src_phase_index, &nominal_src_phase, NULL, + NULL, NULL); if (!m) @@ -8717,6 +8780,47 @@ Scheme_Object *scheme_explode_syntax(Scheme_Object *stx, Scheme_Hash_Table *ht) /**********************************************************************/ +static Scheme_Object *write_free_id_info_prefix(Scheme_Object *obj) +{ + Scheme_Object *vec; + int i; + + vec = scheme_make_vector(8, NULL); + for (i = 0; i < 8; i++) { + SCHEME_VEC_ELS(vec)[i] = SCHEME_VEC_ELS(obj)[i]; + } + if (SCHEME_TRUEP(SCHEME_VEC_ELS(vec)[7])) + SCHEME_VEC_ELS(vec)[7] = scheme_true; + + return vec; +} + +static Scheme_Object *read_free_id_info_prefix(Scheme_Object *obj) +{ + Scheme_Object *vec, *insp; + int i; + + if (!SCHEME_VECTORP(obj) + || (SCHEME_VEC_SIZE(obj) != 8)) + return NULL; + + vec = scheme_make_vector(8, NULL); + for (i = 0; i < 8; i++) { + SCHEME_VEC_ELS(vec)[i] = SCHEME_VEC_ELS(obj)[i]; + } + + if (SCHEME_TRUEP(SCHEME_VEC_ELS(vec)[7])) { + insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); + SCHEME_VEC_ELS(vec)[7] = insp; + } + + vec->type = scheme_free_id_info_type; + + return vec; +} + +/**********************************************************************/ + #ifdef MZ_PRECISE_GC START_XFORM_SKIP; @@ -8732,6 +8836,7 @@ static void register_traversers(void) GC_REG_TRAV(scheme_wrap_chunk_type, mark_wrapchunk); GC_REG_TRAV(scheme_certifications_type, mark_cert); GC_REG_TRAV(scheme_lexical_rib_type, lex_rib); + GC_REG_TRAV(scheme_free_id_info_type, mark_free_id_info); } END_XFORM_SKIP; diff --git a/src/mzscheme/src/stypes.h b/src/mzscheme/src/stypes.h index 047b103b70..1cb9de0bcc 100644 --- a/src/mzscheme/src/stypes.h +++ b/src/mzscheme/src/stypes.h @@ -167,84 +167,85 @@ enum { scheme_module_phase_exports_type, /* 149 */ scheme_logger_type, /* 150 */ scheme_log_reader_type, /* 151 */ + scheme_free_id_info_type, /* 152 */ #ifdef MZTAG_REQUIRED - _scheme_last_normal_type_, /* 152 */ + _scheme_last_normal_type_, /* 153 */ - scheme_rt_weak_array, /* 153 */ + scheme_rt_weak_array, /* 154 */ - scheme_rt_comp_env, /* 154 */ - scheme_rt_constant_binding, /* 155 */ - scheme_rt_resolve_info, /* 156 */ - scheme_rt_optimize_info, /* 157 */ - scheme_rt_compile_info, /* 158 */ - scheme_rt_cont_mark, /* 159 */ - scheme_rt_saved_stack, /* 160 */ - scheme_rt_reply_item, /* 161 */ - scheme_rt_closure_info, /* 162 */ - scheme_rt_overflow, /* 163 */ - scheme_rt_overflow_jmp, /* 164 */ - scheme_rt_meta_cont, /* 165 */ - scheme_rt_dyn_wind_cell, /* 166 */ - scheme_rt_dyn_wind_info, /* 167 */ - scheme_rt_dyn_wind, /* 168 */ - scheme_rt_dup_check, /* 169 */ - scheme_rt_thread_memory, /* 170 */ - scheme_rt_input_file, /* 171 */ - scheme_rt_input_fd, /* 172 */ - scheme_rt_oskit_console_input, /* 173 */ - scheme_rt_tested_input_file, /* 174 */ - scheme_rt_tested_output_file, /* 175 */ - scheme_rt_indexed_string, /* 176 */ - scheme_rt_output_file, /* 177 */ - scheme_rt_load_handler_data, /* 178 */ - scheme_rt_pipe, /* 179 */ - scheme_rt_beos_process, /* 180 */ - scheme_rt_system_child, /* 181 */ - scheme_rt_tcp, /* 182 */ - scheme_rt_write_data, /* 183 */ - scheme_rt_tcp_select_info, /* 184 */ - scheme_rt_namespace_option, /* 185 */ - scheme_rt_param_data, /* 186 */ - scheme_rt_will, /* 187 */ - scheme_rt_struct_proc_info, /* 188 */ - scheme_rt_linker_name, /* 189 */ - scheme_rt_param_map, /* 190 */ - scheme_rt_finalization, /* 191 */ - scheme_rt_finalizations, /* 192 */ - scheme_rt_cpp_object, /* 193 */ - scheme_rt_cpp_array_object, /* 194 */ - scheme_rt_stack_object, /* 195 */ - scheme_rt_preallocated_object, /* 196 */ - scheme_thread_hop_type, /* 197 */ - scheme_rt_srcloc, /* 198 */ - scheme_rt_evt, /* 199 */ - scheme_rt_syncing, /* 200 */ - scheme_rt_comp_prefix, /* 201 */ - scheme_rt_user_input, /* 202 */ - scheme_rt_user_output, /* 203 */ - scheme_rt_compact_port, /* 204 */ - scheme_rt_read_special_dw, /* 205 */ - scheme_rt_regwork, /* 206 */ - scheme_rt_buf_holder, /* 207 */ - scheme_rt_parameterization, /* 208 */ - scheme_rt_print_params, /* 209 */ - scheme_rt_read_params, /* 210 */ - scheme_rt_native_code, /* 211 */ - scheme_rt_native_code_plus_case, /* 212 */ - scheme_rt_jitter_data, /* 213 */ - scheme_rt_module_exports, /* 214 */ - scheme_rt_delay_load_info, /* 215 */ - scheme_rt_marshal_info, /* 216 */ - scheme_rt_unmarshal_info, /* 217 */ - scheme_rt_runstack, /* 218 */ - scheme_rt_sfs_info, /* 219 */ - scheme_rt_validate_clearing, /* 220 */ - scheme_rt_rb_node, /* 221 */ + scheme_rt_comp_env, /* 155 */ + scheme_rt_constant_binding, /* 156 */ + scheme_rt_resolve_info, /* 157 */ + scheme_rt_optimize_info, /* 158 */ + scheme_rt_compile_info, /* 159 */ + scheme_rt_cont_mark, /* 160 */ + scheme_rt_saved_stack, /* 161 */ + scheme_rt_reply_item, /* 162 */ + scheme_rt_closure_info, /* 163 */ + scheme_rt_overflow, /* 164 */ + scheme_rt_overflow_jmp, /* 165 */ + scheme_rt_meta_cont, /* 166 */ + scheme_rt_dyn_wind_cell, /* 167 */ + scheme_rt_dyn_wind_info, /* 168 */ + scheme_rt_dyn_wind, /* 169 */ + scheme_rt_dup_check, /* 170 */ + scheme_rt_thread_memory, /* 171 */ + scheme_rt_input_file, /* 172 */ + scheme_rt_input_fd, /* 173 */ + scheme_rt_oskit_console_input, /* 174 */ + scheme_rt_tested_input_file, /* 175 */ + scheme_rt_tested_output_file, /* 176 */ + scheme_rt_indexed_string, /* 177 */ + scheme_rt_output_file, /* 178 */ + scheme_rt_load_handler_data, /* 179 */ + scheme_rt_pipe, /* 180 */ + scheme_rt_beos_process, /* 181 */ + scheme_rt_system_child, /* 182 */ + scheme_rt_tcp, /* 183 */ + scheme_rt_write_data, /* 184 */ + scheme_rt_tcp_select_info, /* 185 */ + scheme_rt_namespace_option, /* 186 */ + scheme_rt_param_data, /* 187 */ + scheme_rt_will, /* 188 */ + scheme_rt_struct_proc_info, /* 189 */ + scheme_rt_linker_name, /* 190 */ + scheme_rt_param_map, /* 191 */ + scheme_rt_finalization, /* 192 */ + scheme_rt_finalizations, /* 193 */ + scheme_rt_cpp_object, /* 194 */ + scheme_rt_cpp_array_object, /* 195 */ + scheme_rt_stack_object, /* 196 */ + scheme_rt_preallocated_object, /* 197 */ + scheme_thread_hop_type, /* 198 */ + scheme_rt_srcloc, /* 199 */ + scheme_rt_evt, /* 200 */ + scheme_rt_syncing, /* 201 */ + scheme_rt_comp_prefix, /* 202 */ + scheme_rt_user_input, /* 203 */ + scheme_rt_user_output, /* 204 */ + scheme_rt_compact_port, /* 205 */ + scheme_rt_read_special_dw, /* 206 */ + scheme_rt_regwork, /* 207 */ + scheme_rt_buf_holder, /* 208 */ + scheme_rt_parameterization, /* 209 */ + scheme_rt_print_params, /* 210 */ + scheme_rt_read_params, /* 211 */ + scheme_rt_native_code, /* 212 */ + scheme_rt_native_code_plus_case, /* 213 */ + scheme_rt_jitter_data, /* 214 */ + scheme_rt_module_exports, /* 215 */ + scheme_rt_delay_load_info, /* 216 */ + scheme_rt_marshal_info, /* 217 */ + scheme_rt_unmarshal_info, /* 218 */ + scheme_rt_runstack, /* 219 */ + scheme_rt_sfs_info, /* 220 */ + scheme_rt_validate_clearing, /* 221 */ + scheme_rt_rb_node, /* 222 */ #endif - scheme_place_type, /* 222 */ - scheme_engine_type, /* 223 */ + scheme_place_type, /* 223 */ + scheme_engine_type, /* 224 */ _scheme_last_type_ };