diff --git a/collects/2htdp/private/check-aux.ss b/collects/2htdp/private/check-aux.ss index ff81e7b968..094849c8e2 100644 --- a/collects/2htdp/private/check-aux.ss +++ b/collects/2htdp/private/check-aux.ss @@ -135,7 +135,7 @@ ;; Symbol Any String -> Void (define (check-pos t c r) (check-arg - t (and (number? c) (> (number->integer c) 0)) "positive integer" r c)) + t (and (number? c) (>= (number->integer c) 0)) "positive integer" r c)) ;; Symbol Any String String *-> Void (define (check-image tag i rank . other-message) diff --git a/collects/2htdp/universe.ss b/collects/2htdp/universe.ss index d4d4d80981..601f08f949 100644 --- a/collects/2htdp/universe.ss +++ b/collects/2htdp/universe.ss @@ -146,15 +146,18 @@ (syntax-case #'E () [(V) (set! rec? #'V)] [_ (err 'record? stx)])) - (cons (syntax-e #'kw) (syntax E)))] + (cons #'kw #;(syntax-e #'kw) (syntax E)))] [_ (raise-syntax-error 'big-bang "not a legal big-bang clause" stx)])) (syntax->list (syntax (s ...))))] ;; assert: all bind = (kw . E) and kw is constrained via Bind [args (map (lambda (x) (define kw (car x)) - (define co (assq kw Spec)) - (list kw ((cadr co) (cdr x)))) + (define co ;; patch from Jay to allow rename on import + (findf (lambda (n) (free-identifier=? kw (car n))) + (map (lambda (k s) (cons k (cdr s))) + kwds Spec))) + (list (syntax-e (car co)) ((cadr co) (cdr x)))) spec)]) #`(send (new (if #,rec? aworld% world%) [world0 w] #,@args) last))])) @@ -276,7 +279,7 @@ [(kw . E) (and (identifier? #'kw) (for/or ([n kwds]) (free-identifier=? #'kw n))) - (cons (syntax-e #'kw) (syntax E))] + (cons #'kw (syntax E))] [(kw E) (and (identifier? #'kw) (for/or ([n kwds]) (free-identifier=? #'kw n))) @@ -285,6 +288,15 @@ 'universe "not a legal universe clause" stx)])) (syntax->list (syntax (bind ...))))] ;; assert: all bind = (kw . E) and kw is constrained via Bind + [args (map (lambda (x) + (define kw (car x)) + (define co ;; patch from Jay to allow rename on import + (findf (lambda (n) (free-identifier=? kw (car n))) + (map (lambda (k s) (cons k (cdr s))) + kwds Spec))) + (list (syntax-e (car co)) ((cadr co) (cdr x)))) + spec)] + #; [args (map (lambda (x) (define kw (car x)) (define co (assq kw Spec)) diff --git a/collects/compiler/xform.ss b/collects/compiler/xform.ss index 8907315faa..451ab30159 100644 --- a/collects/compiler/xform.ss +++ b/collects/compiler/xform.ss @@ -1,6 +1,7 @@ #lang scheme/base (require dynext/compile + setup/dirs (prefix-in xform: "private/xform.ss")) (provide xform) @@ -11,7 +12,9 @@ (current-extension-preprocess-flags))] [headers (apply append (map (current-make-compile-include-strings) - header-dirs))]) + (append + header-dirs + (list (find-include-dir)))))]) (xform:xform quiet? (cons exe (append flags headers)) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index 49e6ccd3ae..b4d4375997 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -927,7 +927,7 @@ (define rst (read-bytes size* port)) - (unless (eof-object? (read port)) + (unless (eof-object? (read-byte port)) (error 'not-end)) (unless (= size* (bytes-length rst)) diff --git a/collects/deinprogramm/deinprogramm-langs.ss b/collects/deinprogramm/deinprogramm-langs.ss index 4148e3a426..4bb68a456a 100644 --- a/collects/deinprogramm/deinprogramm-langs.ss +++ b/collects/deinprogramm/deinprogramm-langs.ss @@ -177,6 +177,7 @@ (run-in-user-thread (lambda () (read-accept-quasiquote (get-accept-quasiquote?)) + (ensure-drscheme-secrets-declared drs-namespace) (namespace-attach-module drs-namespace ''drscheme-secrets) (namespace-attach-module drs-namespace deinprogramm-struct-module-name) (error-display-handler teaching-languages-error-display-handler) @@ -244,6 +245,27 @@ (super-new))) + ;; this inspector should be powerful enough to see + ;; any structure defined in the user's namespace + (define drscheme-inspector (current-inspector)) + + ;; FIXME: brittle, mimics drscheme-secrets + ;; as declared in lang/htdp-langs.ss. + ;; Is it even needed for DeinProgramm langs? + ;; Only used by htdp/hangman teachpack. + (define (ensure-drscheme-secrets-declared drs-namespace) + (parameterize ((current-namespace drs-namespace)) + (define (declare) + (eval `(,#'module drscheme-secrets mzscheme + (provide drscheme-inspector) + (define drscheme-inspector ,drscheme-inspector))) + (namespace-require ''drscheme-secrets)) + (with-handlers ([exn:fail? (lambda (e) (declare))]) + ;; May have been declared by lang/htdp-langs tool, if loaded + (dynamic-require ''drscheme-secrets 'drscheme-inspector)) + (void))) + + ;; { ;; all this copied from collects/drscheme/private/language.ss @@ -1051,24 +1073,31 @@ answer) (define (stepper-settings-language %) - (class* % (stepper-language<%>) - (init-field stepper:supported) - (define/override (stepper:supported?) stepper:supported) - (define/override (stepper:render-to-sexp val settings language-level) - (parameterize ([pc:current-print-convert-hook (make-print-convert-hook settings)]) - (set-print-settings - language-level - settings - (lambda () - (stepper-convert-value val settings))))) - - (super-new))) + (if (implementation? % stepper-language<%>) + (class* % (stepper-language<%>) + (init-field stepper:supported) + (define/override (stepper:supported?) stepper:supported) + (define/override (stepper:render-to-sexp val settings language-level) + (parameterize ([pc:current-print-convert-hook (make-print-convert-hook settings)]) + (set-print-settings + language-level + settings + (lambda () + (stepper-convert-value val settings))))) + (super-new)) + (class % + (init stepper:supported) + (super-new)))) (define (debugger-settings-language %) - (class* % (debugger-language<%>) - (init-field [debugger:supported #f]) - (define/override (debugger:supported?) debugger:supported) - (super-new))) + (if (implementation? % debugger-language<%>) + (class* % (debugger-language<%>) + (init-field [debugger:supported #f]) + (define/override (debugger:supported?) debugger:supported) + (super-new)) + (class % + (init [debugger:supported #f]) + (super-new)))) ;; make-print-convert-hook: ;; simple-settings -> (TST (TST -> TST) (TST -> TST) -> TST) diff --git a/collects/deinprogramm/scribblings/DMdA-lib.scrbl b/collects/deinprogramm/scribblings/DMdA-lib.scrbl index e372fa50ce..28b3b13712 100644 --- a/collects/deinprogramm/scribblings/DMdA-lib.scrbl +++ b/collects/deinprogramm/scribblings/DMdA-lib.scrbl @@ -10,7 +10,7 @@ lang/prim)) @(define DMdA @italic{Die Macht der Abstraktion}) -@(define (DMdA-ref s) @secref[#:doc '(lib "deinprogramm/scribblings/deinprogramm-langs.scrbl") s]) +@(define (DMdA-ref s) @secref[#:doc '(lib "deinprogramm/scribblings/deinprogramm.scrbl") s]) Note: This is documentation for the language levels that go with the German textbook @italic{@link["http://www.deinprogramm.de/dmda/"]{Die diff --git a/collects/deinprogramm/scribblings/deinprogramm-langs.scrbl b/collects/deinprogramm/scribblings/deinprogramm-langs.scrbl deleted file mode 100644 index 383f5150b7..0000000000 --- a/collects/deinprogramm/scribblings/deinprogramm-langs.scrbl +++ /dev/null @@ -1,25 +0,0 @@ -#lang scribble/doc -@(require scribblings/htdp-langs/common) - -@title{Sprachebenen für @italic{Die Macht der Abstraktion}} - -Note: This is documentation for the language levels that go with the -German textbook @italic{@link["http://www.deinprogramm.de/dmda/"]{Die -Macht der Abstraktion}}. - -Die Sprachebenen in diesem Handbuch sind für Verwendung mit dem Buch -the @italic{@link["http://www.deinprogramm.de/dmda/"]{Die Macht der -Abstraktion}} gedacht. - -@table-of-contents[] - -@;------------------------------------------------------------------------ - -@include-section["DMdA-beginner.scrbl"] -@include-section["DMdA-vanilla.scrbl"] -@include-section["DMdA-assignments.scrbl"] -@include-section["DMdA-advanced.scrbl"] - -@;------------------------------------------------------------------------ - -@index-section[] diff --git a/collects/deinprogramm/scribblings/deinprogramm.scrbl b/collects/deinprogramm/scribblings/deinprogramm.scrbl new file mode 100644 index 0000000000..38ba574949 --- /dev/null +++ b/collects/deinprogramm/scribblings/deinprogramm.scrbl @@ -0,0 +1,33 @@ +#lang scribble/doc + +@(require scribble/manual + (for-label scheme)) + +@title[#:style '(toc) #:tag "deinprogramm"]{Sprachebenen und Material zu @italic{Die Macht der Abstraktion}} + +Note: This is documentation for the teachpacks that go with the German +textbook @italic{@link["http://www.deinprogramm.de/dmda/"]{Die Macht +der Abstraktion}}. + +Das Material in diesem Handbuch ist für die Verwendung mit dem Buch +the @italic{@link["http://www.deinprogramm.de/dmda/"]{Die Macht der +Abstraktion}} gedacht. + +@table-of-contents[] + +@include-section["DMdA-beginner.scrbl"] +@include-section["DMdA-vanilla.scrbl"] +@include-section["DMdA-assignments.scrbl"] +@include-section["DMdA-advanced.scrbl"] + +@include-section["ka.scrbl"] + +@include-section["image.scrbl"] +@include-section["world.scrbl"] +@include-section["turtle.scrbl"] +@include-section["sound.scrbl"] +@include-section["line3d.scrbl"] + +@include-section["DMdA-lib.scrbl"] + +@index-section[] diff --git a/collects/teachpack/deinprogramm/scribblings/image.scrbl b/collects/deinprogramm/scribblings/image.scrbl similarity index 100% rename from collects/teachpack/deinprogramm/scribblings/image.scrbl rename to collects/deinprogramm/scribblings/image.scrbl diff --git a/collects/deinprogramm/scribblings/info.ss b/collects/deinprogramm/scribblings/info.ss index 2ac704094a..24a48b2bb0 100644 --- a/collects/deinprogramm/scribblings/info.ss +++ b/collects/deinprogramm/scribblings/info.ss @@ -1,6 +1,4 @@ #lang setup/infotab -(define scribblings '(("deinprogramm-langs.scrbl" (multi-page) (language -14)) - ("ka.scrbl" (multi-page) (other -10)) - ("DMdA-lib.scrbl"))) +(define scribblings '(("deinprogramm.scrbl" (multi-page) (language -14)))) diff --git a/collects/teachpack/deinprogramm/scribblings/line3d.scrbl b/collects/deinprogramm/scribblings/line3d.scrbl similarity index 100% rename from collects/teachpack/deinprogramm/scribblings/line3d.scrbl rename to collects/deinprogramm/scribblings/line3d.scrbl diff --git a/collects/teachpack/deinprogramm/scribblings/p1.jpg b/collects/deinprogramm/scribblings/p1.jpg similarity index 100% rename from collects/teachpack/deinprogramm/scribblings/p1.jpg rename to collects/deinprogramm/scribblings/p1.jpg diff --git a/collects/teachpack/deinprogramm/scribblings/p2.jpg b/collects/deinprogramm/scribblings/p2.jpg similarity index 100% rename from collects/teachpack/deinprogramm/scribblings/p2.jpg rename to collects/deinprogramm/scribblings/p2.jpg diff --git a/collects/teachpack/deinprogramm/scribblings/p3.jpg b/collects/deinprogramm/scribblings/p3.jpg similarity index 100% rename from collects/teachpack/deinprogramm/scribblings/p3.jpg rename to collects/deinprogramm/scribblings/p3.jpg diff --git a/collects/teachpack/deinprogramm/scribblings/p4.jpg b/collects/deinprogramm/scribblings/p4.jpg similarity index 100% rename from collects/teachpack/deinprogramm/scribblings/p4.jpg rename to collects/deinprogramm/scribblings/p4.jpg diff --git a/collects/teachpack/deinprogramm/scribblings/shared.ss b/collects/deinprogramm/scribblings/shared.ss similarity index 100% rename from collects/teachpack/deinprogramm/scribblings/shared.ss rename to collects/deinprogramm/scribblings/shared.ss diff --git a/collects/teachpack/deinprogramm/scribblings/sound.scrbl b/collects/deinprogramm/scribblings/sound.scrbl similarity index 100% rename from collects/teachpack/deinprogramm/scribblings/sound.scrbl rename to collects/deinprogramm/scribblings/sound.scrbl diff --git a/collects/teachpack/deinprogramm/scribblings/turtle.scrbl b/collects/deinprogramm/scribblings/turtle.scrbl similarity index 100% rename from collects/teachpack/deinprogramm/scribblings/turtle.scrbl rename to collects/deinprogramm/scribblings/turtle.scrbl diff --git a/collects/teachpack/deinprogramm/scribblings/world.scrbl b/collects/deinprogramm/scribblings/world.scrbl similarity index 100% rename from collects/teachpack/deinprogramm/scribblings/world.scrbl rename to collects/deinprogramm/scribblings/world.scrbl diff --git a/collects/drscheme/info.ss b/collects/drscheme/info.ss index 9786880b1f..4ece34f38a 100644 --- a/collects/drscheme/info.ss +++ b/collects/drscheme/info.ss @@ -1,6 +1,6 @@ #lang setup/infotab -(define tools '("syncheck.ss")) -(define tool-names '("Check Syntax")) +(define tools '("syncheck.ss" #;"sprof.ss")) +(define tool-names '("Check Syntax" #;"Sampling Profiler")) (define mred-launcher-names '("DrScheme")) (define mred-launcher-libraries '("drscheme.ss")) diff --git a/collects/drscheme/private/language-configuration.ss b/collects/drscheme/private/language-configuration.ss index 711317ad3e..299b9dec14 100644 --- a/collects/drscheme/private/language-configuration.ss +++ b/collects/drscheme/private/language-configuration.ss @@ -521,9 +521,9 @@ (send language default-settings)))] [else (values #f #f)])]) (cond - [(not vis-lang) (void)] - [(equal? (send vis-lang get-language-position) - (send language get-language-position)) + [(and vis-lang + (equal? (send vis-lang get-language-position) + (send language get-language-position))) (get/set-settings vis-settings) (send details-panel active-child language-details-panel)] [else @@ -761,8 +761,6 @@ (send revert-to-defaults-outer-panel stretchable-height #f) (send outermost-panel set-alignment 'center 'center) - (update-show/hide-details) - (for-each add-language-to-dialog languages) (send languages-hier-list sort (λ (x y) @@ -820,6 +818,7 @@ (get/set-selected-language-settings settings-to-show)) (when details-shown? (do-construct-details)) + (update-show/hide-details) (send languages-hier-list focus) (values (λ () selected-language) diff --git a/collects/drscheme/sprof.ss b/collects/drscheme/sprof.ss new file mode 100644 index 0000000000..099dc03230 --- /dev/null +++ b/collects/drscheme/sprof.ss @@ -0,0 +1,398 @@ +#lang scheme/base +(require scheme/gui/base + framework + scheme/class) + +;; how long between samples +(define pause-time 0.1) + +;; gui updates occur every 'update-frequency' samples +(define update-frequency 4) + +(define (make-prod-thread get-threads update-gui) + (thread (lambda () + (define traces-table (make-hash)) + (let loop ([i 0]) + (sleep pause-time) + (let ([new-traces + (map (λ (t) (continuation-mark-set->context (continuation-marks t))) + (get-threads))]) + (for-each + (λ (trace) + (for-each + (λ (line) + (hash-set! traces-table line (cons trace (hash-ref traces-table line '())))) + trace)) + new-traces) + (cond + [(zero? i) + (update-gui traces-table) + (loop update-frequency)] + [else + (loop (- i 1))])))))) + +(define (format-fn-name i) + (let ([id (car i)] + [src (cdr i)]) + (cond + [id (format "~a" id)] + [src + (format "~a:~a~a" + (cond + [(path? (srcloc-source src)) + (let-values ([(base name dir?) (split-path (srcloc-source src))]) + name)] + [else (srcloc-source src)]) + (if (srcloc-line src) + (format "~a:~a" + (srcloc-line src) + (srcloc-column src)) + (srcloc-position src)) + (if id + (format ": ~a" id) + ""))] + [else "???"]))) + +(define (insert-long-fn-name t i) + (send t begin-edit-sequence) + (send t erase) + (let ([id (car i)] + [src (cdr i)]) + (when src + (send t insert + (format "~a:~a" + (srcloc-source src) + (if (srcloc-line src) + (format "~a:~a" + (srcloc-line src) + (srcloc-column src)) + (format ":~a" (srcloc-position src)))))) + (when (and id src) + (send t insert "\n")) + (when id + (send t insert (format (format "~a" id)))) + (unless (or id src) + (send t insert "???"))) + (send t end-edit-sequence)) + +(define (format-percentage n) + (let ([trunc (floor (* n 100))]) + (format "~a%" (pad3 trunc)))) + +(define (pad3 n) + (cond + [(< n 10) (format "00~a" n)] + [(< n 100) (format "0~a" n)] + [else (format "~a" n)])) + +(define cumulative-t% + (class text:basic% + (init-field open-button vp ec1 lp info-editor) + (inherit begin-edit-sequence + end-edit-sequence + erase + find-position + get-admin + dc-location-to-editor-location + position-paragraph + insert + last-position + highlight-range + last-paragraph + lock) + + (define gui-display-data '()) + (define clicked-srcloc-pr #f) + (define line-to-source (make-hasheq)) + + (define clear-old-pr void) + + (define/override (on-event event) + (cond + [(send event button-up? 'left) + (let ([admin (get-admin)]) + (when admin + (let ([dc (send admin get-dc)]) + (let-values ([(x y) (dc-location-to-editor-location (send event get-x) + (send event get-y))]) + (let* ([loc (find-position x y)] + [para (position-paragraph loc)]) + (set! clicked-srcloc-pr (and (<= 0 para (last-paragraph)) + (car (list-ref gui-display-data para)))) + (update-gui-display))))))] + [else (void)])) + + (define/public (set-gui-display-data/refresh traces-table) + (set! gui-display-data + (sort (hash-map traces-table (λ (k v) (cons k v))) + > + #:key (λ (x) (length (cdr x))))) + (update-gui-display)) + + (define/public (clear-clicked) + (set! clicked-srcloc-pr #f) + (update-gui-display)) + + (define/private (update-gui-display) + (lock #f) + (begin-edit-sequence) + (erase) + (set! line-to-source (make-hasheq)) + (clear-old-pr) + (set! clear-old-pr void) + (let* ([denom-ht (make-hasheq)] + [filtered-gui-display-data + (map + (λ (pr) + (let ([id (car pr)] + [stacks (filter-stacks (cdr pr))]) + (for-each (λ (stack) (hash-set! denom-ht stack #t)) stacks) + (cons id stacks))) + gui-display-data)] + [denom-count (hash-count denom-ht)]) + (let loop ([prs filtered-gui-display-data] + [first? #t] + [i 0]) + (cond + [(null? prs) (void)] + [else + (let* ([pr (car prs)] + [fn (car pr)] + [count (length (cdr pr))]) + (cond + [(zero? count) + (loop (cdr prs) first? i)] + [else + (unless first? (insert "\n")) + (let ([before (last-position)]) + (hash-set! line-to-source i pr) + (insert (format-percentage (/ count denom-count))) + (insert (format " ~a" (format-fn-name fn))) + (let ([after (last-position)]) + (when (equal? (car pr) clicked-srcloc-pr) + (set! clear-old-pr (highlight-range before after "NavajoWhite"))))) + (loop (cdr prs) #f (+ i 1))]))])) + (lock #t) + (end-edit-sequence) + (update-info-editor clicked-srcloc-pr) + (send open-button enable (and clicked-srcloc-pr (path? (srcloc-source (cdr clicked-srcloc-pr))))))) + + (define/private (filter-stacks stacks) + (cond + [(not clicked-srcloc-pr) stacks] + [else + (filter (λ (stack) (ormap (λ (stack-ent) (equal? clicked-srcloc-pr stack-ent)) + stack)) + stacks)])) + + (define/public (open-current-pr) + (when clicked-srcloc-pr + (let ([src (cdr clicked-srcloc-pr)]) + (when (path? (srcloc-source src)) + (printf "open ~s\n" (srcloc-source src)) + (when (number? (srcloc-position src)) + (printf "go to ~s\n" (srcloc-position src))))))) + + (define/private (update-info-editor pr) + (send vp change-children (λ (l) (if pr (list ec1 lp) (list ec1)))) + (when pr + (insert-long-fn-name info-editor pr))) + + (super-new))) + +(define (construct-gui f) + (define info-editor (new text%)) + (define vp (new vertical-panel% [parent f])) + (define ec1 (new editor-canvas% [parent vp])) + (define lp (new vertical-panel% [parent vp] [stretchable-height #f])) + (define ec2 (new editor-canvas% + [parent lp] + [min-height 100] + [stretchable-height #f] + [editor info-editor])) + (define bp (new horizontal-panel% [stretchable-height #f] [parent lp] [alignment '(center center)])) + (define open-button (new button% + [parent bp] + [label "Open"] + [callback + (λ (x y) + (send cumulative-t open-current-pr))])) + (define unlock (new button% + [label "Show All"] + [parent bp] + [callback + (λ (x y) + (send cumulative-t clear-clicked))])) + (define cumulative-t (new cumulative-t% + [open-button open-button] + [vp vp] + [ec1 ec1] + [lp lp] + [info-editor info-editor])) + (send ec1 set-editor cumulative-t) + (send vp change-children (λ (l) (list ec1))) + (send cumulative-t hide-caret #t) + (send cumulative-t lock #t) + (send info-editor auto-wrap #t) + (values vp cumulative-t)) + +;; running an example outside of drscheme +#; +(begin + (define evt (make-eventspace)) + (define f (parameterize ([current-eventspace evt]) + (new frame% + [label ""] + [width 400] + [height 800]))) + (define-values (panel cumulative-t) (construct-gui f)) + (send f show #t) + + (void (make-prod-thread (let ([t (current-thread)]) + (λ () (list t))) + (λ (traces-table) + (parameterize ([current-eventspace evt]) + (queue-callback + (λ () + (send cumulative-t set-gui-display-data/refresh traces-table))))))) + + (time (dynamic-require '(lib "scribblings/reference/reference.scrbl") + #f))) + +;; tool code, for integration with drscheme +(begin + (require drscheme/tool + scheme/unit + string-constants/string-constant) + + (define sc-show-sprof "Show SProfile") + (define sc-hide-sprof "Hide SProfile") + + (provide tool@) + (define tool@ + (unit + (import drscheme:tool^) + (export drscheme:tool-exports^) + (define (phase1) (void)) + (define (phase2) (void)) + + (define-local-member-name + show/hide-sprof-panel + update-sprof-panel + toggle-sprof-visiblity + stop-profiling-thread + start-profiling-thread + get-threads-to-profile) + + (define unit-frame-mixin + (mixin (drscheme:unit:frame<%>) () + (inherit get-current-tab) + + (define main-panel #f) + (define sprof-main-panel #f) + (define everything-else #f) + (define cumulative-t #f) + (define show/hide-menu-item #f) + + (define/public (show/hide-sprof-panel show?) + (let ([main-children (send main-panel get-children)]) + (send show/hide-menu-item + set-label + (if show? sc-hide-sprof sc-show-sprof)) + (unless (or (and show? (= 2 (length main-children))) + (and (not show?) (= 1 (length main-children)))) + (send main-panel change-children + (λ (l) + (if show? + (list everything-else sprof-main-panel) + (list everything-else))))))) + + (define/override (make-root-area-container cls parent) + (set! main-panel (super make-root-area-container panel:horizontal-dragable% parent)) + (set! everything-else (make-object cls main-panel)) + (set!-values (sprof-main-panel cumulative-t) (construct-gui main-panel)) + (send main-panel change-children (λ (l) (list everything-else))) + everything-else) + + (define/augment (on-tab-change from-tab to-tab) + (inner (void) on-tab-change from-tab to-tab) + (send to-tab update-sprof-panel)) + + (define/override (add-show-menu-items show-menu) + (super add-show-menu-items show-menu) + (set! show/hide-menu-item + (new menu-item% + [parent show-menu] + [label sc-show-sprof] + [callback + (λ (x y) + (send (get-current-tab) toggle-sprof-visiblity))]))) + + ;; FIX: the cumulative-t text object shouldn't be handed out like this + ;; instead its contents need to be tab specific, so switching tabs + ;; (ala the update-sprof-panel method) should change the contents of + ;; the cumulative-t, presumably via the set-gui-display-data/refresh method. + (define/public (get-cumulative-t) cumulative-t) + + (super-new))) + + (define tab-mixin + (mixin (drscheme:unit:tab<%>) () + (inherit get-frame get-ints) + (define prof-visible? #f) + (define/public (toggle-sprof-visiblity) + (set! prof-visible? (not prof-visible?)) + (cond + [prof-visible? + (start-profiling-thread)] + [else + (stop-profiling-thread)]) + (update-sprof-panel)) + (define/public (update-sprof-panel) + (send (get-frame) show/hide-sprof-panel prof-visible?)) + + (define profiling-thread #f) + + (define/public (stop-profiling-thread) + (when profiling-thread + (kill-thread profiling-thread)) + (set! profiling-thread #f)) + + (define current-traces-table #f) + + (define/public (start-profiling-thread) + (stop-profiling-thread) + (set! profiling-thread (make-prod-thread + (λ () (send (get-ints) get-threads-to-profile)) + (λ (traces-table) + (queue-callback + (λ () + (send (send (get-frame) get-cumulative-t) set-gui-display-data/refresh traces-table))))))) + + (super-new))) + + (define system-custodian (current-custodian)) + + (define repl-mixin + (mixin (drscheme:rep:text<%>) () + (inherit get-user-custodian) + (define/public (get-threads-to-profile) + (let ([thds '()]) + (let loop ([cust (get-user-custodian)]) + (for-each + (λ (obj) + (cond + [(custodian? obj) (loop obj)] + [(thread? obj) (set! thds (cons obj thds))])) + (custodian-managed-list cust system-custodian))) + thds)) + + ;; FIX + ;; something needs to happen here so that the profiling gets shutdown when the repl dies. + ;; the right call back isn't obvious, tho. :( + + (super-new))) + + (drscheme:get/extend:extend-tab tab-mixin) + (drscheme:get/extend:extend-interactions-text repl-mixin) + (drscheme:get/extend:extend-unit-frame unit-frame-mixin)))) diff --git a/collects/drscheme/tool-lib.ss b/collects/drscheme/tool-lib.ss index 708e4123f1..d18f85b627 100644 --- a/collects/drscheme/tool-lib.ss +++ b/collects/drscheme/tool-lib.ss @@ -673,8 +673,8 @@ all of the names in the tools library, for use defining keybindings (proc-doc/names drscheme:get/extend:extend-tab (case-> - ((make-mixin-contract drscheme:unit:tab%) . -> . void?) - ((make-mixin-contract drscheme:unit:tab%) boolean? . -> . void?)) + ((make-mixin-contract drscheme:unit:tab<%>) . -> . void?) + ((make-mixin-contract drscheme:unit:tab<%>) boolean? . -> . void?)) ((mixin) (mixin before?)) @{This class implements the tabs in drscheme. One is created for each tab diff --git a/collects/ffi/objc.scrbl b/collects/ffi/objc.scrbl index a43ccb9713..b2b984d44c 100644 --- a/collects/ffi/objc.scrbl +++ b/collects/ffi/objc.scrbl @@ -14,9 +14,7 @@ @title{@bold{Objective-C} FFI} -@declare-exporting[ffi/private/objc-doc-unsafe #:use-sources (ffi/objc)] - -@defmodule*/no-declare[(ffi/objc)]{The @schememodname[ffi/objc] library builds on +@defmodule[ffi/objc]{The @schememodname[ffi/objc] library builds on @schememodname[scheme/foreign] to support interaction with @link["http://developer.apple.com/documentation/Cocoa/Conceptual/ObjectiveC/"]{Objective-C}.} diff --git a/collects/ffi/private/objc-doc-unsafe.ss b/collects/ffi/private/objc-doc-unsafe.ss index 20ecc1eb89..6aad33ea1e 100644 --- a/collects/ffi/private/objc-doc-unsafe.ss +++ b/collects/ffi/private/objc-doc-unsafe.ss @@ -6,5 +6,11 @@ (objc-unsafe!) -(provide (protect-out (all-defined-out)) +(provide (protect-out objc_msgSend/typed + objc_msgSendSuper/typed + import-class + get-ivar set-ivar! + selector + tell tellv + define-objc-class) (all-from-out ffi/objc)) diff --git a/collects/file/scribblings/tar.scrbl b/collects/file/scribblings/tar.scrbl index 8f019ddc51..07c85d863f 100644 --- a/collects/file/scribblings/tar.scrbl +++ b/collects/file/scribblings/tar.scrbl @@ -1,6 +1,6 @@ #lang scribble/doc @(require "common.ss" - (for-label file/tar)) + (for-label file/tar file/gzip)) @title[#:tag "tar"]{@exec{tar} File Creation} @@ -13,7 +13,7 @@ information is not preserved; the owner that is stored in the archive is always ``root.''} @defproc[(tar [tar-file path-string?][path path-string?] ...) - void?]{ + exact-nonnegative-integer?]{ Creates @scheme[tar-file], which holds the complete content of all @scheme[path]s. The given @scheme[path]s are all expected to be @@ -23,12 +23,18 @@ to the current directory). If a nested path is provided as a resulting tar file, up to the current directory (using @scheme[pathlist-closure]).} -@defproc[(tar->output [paths (listof path-string?)] +@defproc[(tar->output [paths (listof path?)] [out output-port? (current-output-port)]) - void?]{ + exact-nonnegative-integer?]{ Packages each of the given @scheme[paths] in a @exec{tar} format archive that is written directly to the @scheme[out]. The specified @scheme[paths] are included as-is; if a directory is specified, its content is not automatically added, and nested directories are added without parent directories.} + +@defproc[(tar-gzip [tar-file path-string?] [paths path-string?] ...) + void?]{ + +Like @scheme[tar], but compresses the resulting file with @scheme[gzip]. +} diff --git a/collects/gui-debugger/debug-tool.ss b/collects/gui-debugger/debug-tool.ss index 3efc59a2b9..de7e2978b1 100644 --- a/collects/gui-debugger/debug-tool.ss +++ b/collects/gui-debugger/debug-tool.ss @@ -1006,14 +1006,6 @@ (define/public (hide-debug) (send (get-frame) hide-debug)) - (define/override (enable-evaluation) - (send (send (get-frame) get-debug-button) enable #t) - (super enable-evaluation)) - - (define/override (disable-evaluation) - (send (send (get-frame) get-debug-button) enable #f) - (super disable-evaluation)) - (super-new))) (define debug-bitmap @@ -1285,6 +1277,14 @@ (inherit register-toolbar-button) (register-toolbar-button debug-button) + (define/augment (enable-evaluation) + (send debug-button enable #t) + (inner (void) enable-evaluation)) + + (define/augment (disable-evaluation) + (send debug-button enable #f) + (inner (void) disable-evaluation)) + (define pause-button (instantiate button% () [label (make-pause-label this)] diff --git a/collects/htdp/world.ss b/collects/htdp/world.ss index 93f745c977..1a1228484d 100644 --- a/collects/htdp/world.ss +++ b/collects/htdp/world.ss @@ -183,8 +183,8 @@ Matthew ; (define (nw:rectangle width height mode color) - (check-pos 'rectangle width "first") - (check-pos 'rectangle height "second") + (check-size/0 'nw:rectangle width "first") + (check-size/0 'nw:rectangle height "second") (check-mode 'rectangle mode "third") (check-color 'rectangle color "fourth") (put-pinhole (rectangle width height mode color) 0 0)) @@ -199,8 +199,8 @@ Matthew (place-image0 image x y scene))) (define (empty-scene width height) - (check-pos 'empty-scene width "first") - (check-pos 'empty-scene height "second") + (check-size/0 'empty-scene width "first") + (check-size/0 'empty-scene height "second") (put-pinhole (overlay (rectangle width height 'solid 'white) (rectangle width height 'outline 'black)) @@ -253,8 +253,8 @@ Matthew (case-lambda [(w h delta world) (big-bang w h delta world #f)] [(w h delta world animated-gif) - (check-pos 'big-bang w "first") - (check-pos 'big-bang h "second") + (check-size/0 'big-bang w "first") + (check-size/0 'big-bang h "second") ;; ============================================ ;; WHAT IF THEY ARE NOT INTs? ;; ============================================ @@ -361,8 +361,8 @@ Matthew (define run-simulation0 (case-lambda [(width height rate f record?) - (check-pos 'run-simulation width "first") - (check-pos 'run-simulation height "second") + (check-size/0 'run-simulation width "first") + (check-size/0 'run-simulation height "second") (check-arg 'run-simulation (number? rate) 'number "third" rate) (check-proc 'run-simulation f 1 "fourth" "one argument") (check-arg 'run-simulation (boolean? record?) 'number "fifth [and optional]" record?) @@ -390,9 +390,9 @@ Matthew ; ;; Symbol Any String -> Void -(define (check-pos tag c rank) - (check-arg tag (and (number? c) (> (coerce c) 0)) - "positive integer" rank c)) +(define (check-size/0 tag c rank) + (check-arg tag (and (number? c) (>= (coerce c) 0)) + "natural number" rank c)) ;; Symbol Any String String *-> Void (define (check-image tag i rank . other-message) diff --git a/collects/lang/htdp-langs.ss b/collects/lang/htdp-langs.ss index 37fbadc1af..65ffafd3f9 100644 --- a/collects/lang/htdp-langs.ss +++ b/collects/lang/htdp-langs.ss @@ -864,7 +864,9 @@ (init-field [debugger:supported #f]) (define/override (debugger:supported?) debugger:supported) (super-new)) - %)) + (class % + (init [debugger:supported #f]) + (super-new)))) ;; filter/hide-ids : syntax[list] -> listof syntax (define (filter/hide-ids ids) diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss index 527a094261..bb92f312be 100644 --- a/collects/macro-debugger/model/reductions.ss +++ b/collects/macro-debugger/model/reductions.ss @@ -3,7 +3,6 @@ (require scheme/match "stx-util.ss" "deriv-util.ss" - "context.ss" "deriv.ss" "reductions-engine.ss") @@ -61,7 +60,7 @@ [#:when (not (bound-identifier=? e1 e2)) [#:walk e2 'resolve-variable]])] [(Wrap p:module (e1 e2 rs ?1 ?2 tag rename check tag2 ?3 body shift)) - (R ;; [#:hide-check rs] ;; FIXME: test and enable!!! + (R [#:hide-check rs] [! ?1] [#:pattern (?module ?name ?language . ?body-parts)] [! ?2] diff --git a/collects/macro-debugger/syntax-browser/pretty-helper.ss b/collects/macro-debugger/syntax-browser/pretty-helper.ss index 846eae3a0c..4688d2b1b0 100644 --- a/collects/macro-debugger/syntax-browser/pretty-helper.ss +++ b/collects/macro-debugger/syntax-browser/pretty-helper.ss @@ -89,6 +89,13 @@ lp-datum)] [(pair? obj) (pairloop obj)] + [(struct? obj) + ;; Only traverse prefab structs + (let ([pkey (prefab-struct-key obj)]) + (if pkey + (let-values ([(refold fields) (unfold-pstruct obj)]) + (refold (map loop fields))) + obj))] [(symbol? obj) (unintern obj)] [(null? obj) @@ -117,6 +124,14 @@ flat=>stx stx=>flat)))) +;; unfold-pstruct : prefab-struct -> (values (list -> prefab-struct) list) +(define (unfold-pstruct obj) + (define key (prefab-struct-key obj)) + (define fields (cdr (vector->list (struct->vector obj)))) + (values (lambda (new-fields) + (apply make-prefab-struct key new-fields)) + fields)) + ;; check+convert-special-expression : syntax -> #f/syntaxish (define (check+convert-special-expression stx) (define stx-list (stx->list stx)) diff --git a/collects/macro-debugger/syntax-browser/pretty-printer.ss b/collects/macro-debugger/syntax-browser/pretty-printer.ss index 417e52b711..3fbb89a356 100644 --- a/collects/macro-debugger/syntax-browser/pretty-printer.ss +++ b/collects/macro-debugger/syntax-browser/pretty-printer.ss @@ -56,7 +56,7 @@ ;; Printing parameters (mzscheme manual 7.9.1.4) [print-unreadable #t] [print-graph #f] - [print-struct #f] + [print-struct #t] [print-box #t] [print-vector-length #t] [print-hash-table #f] diff --git a/collects/macro-debugger/tool.ss b/collects/macro-debugger/tool.ss index af578c1620..1d1430aae2 100644 --- a/collects/macro-debugger/tool.ss +++ b/collects/macro-debugger/tool.ss @@ -79,7 +79,6 @@ (define drscheme-eventspace (current-eventspace)) (define-local-member-name check-language) - (define-local-member-name get-debug-button) (define macro-debugger-bitmap (make-object bitmap% @@ -113,6 +112,13 @@ (inherit register-toolbar-button) (register-toolbar-button macro-debug-button) + (define/augment (enable-evaluation) + (send macro-debug-button enable #t) + (inner (void) enable-evaluation)) + (define/augment (disable-evaluation) + (send macro-debug-button enable #f) + (inner (void) disable-evaluation)) + (define/override (execute-callback) (execute #f)) @@ -120,8 +126,6 @@ (send (get-interactions-text) enable-macro-debugging debugging?) (super execute-callback)) - (define/public (get-debug-button) macro-debug-button) - ;; Hide button for inappropriate languages (define/augment (on-tab-change old new) @@ -157,17 +161,6 @@ (inner (void) after-set-next-settings s)) (super-new))) - (define (macro-debugger-tab-mixin %) - (class % - (inherit get-frame) - (define/override (enable-evaluation) - (super enable-evaluation) - (send (send (get-frame) get-debug-button) enable #t)) - (define/override (disable-evaluation) - (super disable-evaluation) - (send (send (get-frame) get-debug-button) enable #f)) - (super-new))) - (define (macro-debugger-interactions-text-mixin %) (class % (super-new) @@ -268,7 +261,5 @@ macro-debugger-interactions-text-mixin) (drscheme:get/extend:extend-definitions-text macro-debugger-definitions-text-mixin) - (drscheme:get/extend:extend-tab - macro-debugger-tab-mixin) )) diff --git a/collects/mzlib/deflate.ss b/collects/mzlib/deflate.ss index 125db9e05e..c0f89d1222 100644 --- a/collects/mzlib/deflate.ss +++ b/collects/mzlib/deflate.ss @@ -2062,7 +2062,7 @@ (when header (put_short len) - (put_short (bitwise-not len)) + (put_short (bitwise-and (bitwise-not len) #xFFFF)) (set! bits_sent (+ bits_sent (* 2 16)))) (set! bits_sent (+ bits_sent (<< len 3))) @@ -2112,7 +2112,7 @@ ;; /* Output a 32 bit value to the bit stream, lsb first */ (define (put_long n) (put_short (bitwise-and #xFFFF n)) - (put_short (>> n 16))) + (put_short (bitwise-and #xFFFF (>> n 16)))) (define outcnt 0) (define bytes_out 0) diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index 5ca2e2446e..00d2ccebd7 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -1,1620 +1,4 @@ -#lang scheme/base -;; Foreign Scheme interface -(require '#%foreign setup/dirs - (for-syntax scheme/base scheme/list syntax/stx)) - -;; This module is full of unsafe bindings that are not provided to requiring -;; modules. Instead, an `unsafe!' binding is provided that makes these unsafe -;; bindings available. The following two syntaxes do that: `provide*' is like -;; `provide', but using `(unsafe id)' registers an unsafe binding. Then, -;; `define-unsafer' should be used with a binding that will expose the unsafe -;; bindings. This might move elsewhere at some point if it turns out to be -;; useful in other contexts. -(provide provide* define-unsafer) -(define-syntaxes (provide* define-unsafer) - (let ((unsafe-bindings '())) - (values - (lambda (stx) - (syntax-case stx () - [(_ p ...) - (let loop ([provides '()] - [unsafes '()] - [ps (syntax->list #'(p ...))]) - (if (null? ps) - (begin (set! unsafe-bindings - (append unsafe-bindings (reverse unsafes))) - (with-syntax ([(p ...) provides]) #'(provide p ...))) - (syntax-case (car ps) (unsafe) - [(unsafe u) - (syntax-case #'u (rename-out) - [(rename-out [from to]) - (loop provides (cons (cons #'from #'to) unsafes) (cdr ps))] - [id (identifier? #'id) - (loop provides (cons (cons #'id #'id) unsafes) (cdr ps))] - [_ - (raise-syntax-error 'provide* "bad unsafe usage" - (car ps) stx)])] - [_ (loop (cons (car ps) provides) unsafes (cdr ps))])))])) - (lambda (stx) - (syntax-case stx () - [(_ unsafe) - (with-syntax ([(from ...) (map car unsafe-bindings)] - [(to ...) (map cdr unsafe-bindings)] - [(id ...) (generate-temporaries unsafe-bindings)]) - (set! unsafe-bindings '()) - #'(begin - (provide (protect-out unsafe)) - (define-syntax (unsafe stx) - (syntax-case stx () - [(_) (with-syntax ([(id ...) (list (datum->syntax - stx 'to stx) - ...)]) - #'(begin (define-syntax id - (make-rename-transformer #'from)) - ...))]))))]))))) - -(provide* ctype-sizeof ctype-alignof compiler-sizeof - (unsafe malloc) (unsafe free) (unsafe end-stubborn-change) - cpointer? ptr-equal? ptr-add (unsafe ptr-ref) (unsafe ptr-set!) - ptr-offset ptr-add! offset-ptr? set-ptr-offset! - ctype? make-ctype make-cstruct-type (unsafe make-sized-byte-string) ctype->layout - _void _int8 _uint8 _int16 _uint16 _int32 _uint32 _int64 _uint64 - _fixint _ufixint _fixnum _ufixnum - _float _double _double* - _bool _pointer _scheme _fpointer function-ptr - (unsafe memcpy) (unsafe memmove) (unsafe memset) - (unsafe malloc-immobile-cell) (unsafe free-immobile-cell)) - -(define-syntax define* - (syntax-rules () - [(_ (name . args) body ...) - (begin (provide name) (define (name . args) body ...))] - [(_ name expr) - (begin (provide name) (define name expr))])) - -;; ---------------------------------------------------------------------------- -;; C integer types - -(define* _sint8 _int8) -(define* _sint16 _int16) -(define* _sint32 _int32) -(define* _sint64 _int64) - -;; _byte etc is a convenient name for _uint8 & _sint8 -;; (_byte is unsigned) -(define* _byte _uint8) -(define* _ubyte _uint8) -(define* _sbyte _int8) - -;; _word etc is a convenient name for _uint16 & _sint16 -;; (_word is unsigned) -(define* _word _uint16) -(define* _uword _uint16) -(define* _sword _int16) - -;; _short etc is a convenient name for whatever is the compiler's `short' -;; (_short is signed) -(provide _short _ushort _sshort) -(define-values (_short _ushort _sshort) - (case (compiler-sizeof 'short) - [(2) (values _int16 _uint16 _int16)] - [(4) (values _int32 _uint32 _int32)] - [else (error 'foreign "internal error: bad compiler size for `short'")])) - -;; _int etc is a convenient name for whatever is the compiler's `int' -;; (_int is signed) -(provide _int _uint _sint) -(define-values (_int _uint _sint) - (case (compiler-sizeof 'int) - [(2) (values _int16 _uint16 _int16)] - [(4) (values _int32 _uint32 _int32)] - [(8) (values _int64 _uint64 _int64)] - [else (error 'foreign "internal error: bad compiler size for `int'")])) - -;; _long etc is a convenient name for whatever is the compiler's `long' -;; (_long is signed) -(provide _long _ulong _slong) -(define-values (_long _ulong _slong) - (case (compiler-sizeof 'long) - [(4) (values _int32 _uint32 _int32)] - [(8) (values _int64 _uint64 _int64)] - [else (error 'foreign "internal error: bad compiler size for `long'")])) - -;; _llong etc is a convenient name for whatever is the compiler's `long long' -;; (_llong is signed) -(provide _llong _ullong _sllong) -(define-values (_llong _ullong _sllong) - (case (compiler-sizeof '(long long)) - [(4) (values _int32 _uint32 _int32)] - [(8) (values _int64 _uint64 _int64)] - [else (error 'foreign "internal error: bad compiler size for `llong'")])) - -;; ---------------------------------------------------------------------------- -;; Getting and setting library objects - -(define lib-suffix (bytes->string/latin-1 (subbytes (system-type 'so-suffix) 1))) -(define lib-suffix-re (regexp (string-append "\\." lib-suffix "$"))) -(define suffix-before-version? (not (equal? lib-suffix "dylib"))) - -(provide* (unsafe (rename-out [get-ffi-lib ffi-lib])) - ffi-lib? ffi-lib-name) -(define get-ffi-lib - (case-lambda - [(name) (get-ffi-lib name "")] - [(name version/s) - (cond - [(not name) (ffi-lib name)] ; #f => NULL => open this executable - [(not (or (string? name) (path? name))) - (raise-type-error 'ffi-lib "library-name" name)] - [else - ;; A possible way that this might be misleading: say that there is a - ;; "foo.so" file in the current directory, which refers to some - ;; undefined symbol, trying to use this function with "foo.so" will try - ;; a dlopen with "foo.so" which isn't found, then it tries a dlopen with - ;; "//foo.so" which fails because of the undefined symbol, and - ;; since all fails, it will use (ffi-lib "foo.so") to raise the original - ;; file-not-found error. This is because the dlopen doesn't provide a - ;; way to distinguish different errors (only dlerror, but that's - ;; unreliable). - (let* ([versions (if (list? version/s) version/s (list version/s))] - [versions (map (lambda (v) - (if (or (not v) (zero? (string-length v))) - "" (string-append "." v))) - versions)] - [fullpath (lambda (p) (path->complete-path (cleanse-path p)))] - [absolute? (absolute-path? name)] - [name0 (path->string (cleanse-path name))] ; orig name - [names (map (if (regexp-match lib-suffix-re name0) ; name+suffix - (lambda (v) (string-append name0 v)) - (lambda (v) - (if suffix-before-version? - (string-append name0 "." lib-suffix v) - (string-append name0 v "." lib-suffix)))) - versions)] - [ffi-lib* (lambda (name) (ffi-lib name #t))]) - (or ;; try to look in our library paths first - (and (not absolute?) - (ormap (lambda (dir) - ;; try good names first, then original - (or (ormap (lambda (name) - (ffi-lib* (build-path dir name))) - names) - (ffi-lib* (build-path dir name0)))) - (get-lib-search-dirs))) - ;; try a system search - (ormap ffi-lib* names) ; try good names first - (ffi-lib* name0) ; try original - (ormap (lambda (name) ; try relative paths - (and (file-exists? name) (ffi-lib* (fullpath name)))) - names) - (and (file-exists? name0) ; relative with original - (ffi-lib* (fullpath name0))) - ;; give up: call ffi-lib so it will raise an error - (ffi-lib (car names))))])])) - -(define (get-ffi-lib-internal x) - (if (ffi-lib? x) x (get-ffi-lib x))) - -;; These internal functions provide the functionality to be used by -;; get-ffi-obj, set-ffi-obj! and define-c below -(define (ffi-get ffi-obj type) - (ptr-ref ffi-obj type)) -(define (ffi-set! ffi-obj type new) - (let-values ([(new type) (get-lowlevel-object new type)]) - (hash-set! ffi-objects-ref-table ffi-obj new) - (ptr-set! ffi-obj type new))) - -;; This is better handled with `make-c-parameter' -(provide* (unsafe ffi-obj-ref)) -(define ffi-obj-ref - (case-lambda - [(name lib) (ffi-obj-ref name lib #f)] - [(name lib failure) - (let ([name (get-ffi-obj-name 'ffi-obj-ref name)] - [lib (get-ffi-lib-internal lib)]) - (with-handlers ([exn:fail:filesystem? - (lambda (e) (if failure (failure) (raise e)))]) - (ffi-obj name lib)))])) - -;; get-ffi-obj is implemented as a syntax only to be able to propagate the -;; foreign name into the type syntax, which allows generated wrappers to have a -;; proper name. -(provide* (unsafe get-ffi-obj)) -(define get-ffi-obj* - (case-lambda - [(name lib type) (get-ffi-obj* name lib type #f)] - [(name lib type failure) - (let ([name (get-ffi-obj-name 'get-ffi-obj name)] - [lib (get-ffi-lib-internal lib)]) - (let-values ([(obj error?) - (with-handlers - ([exn:fail:filesystem? - (lambda (e) - (if failure (values (failure) #t) (raise e)))]) - (values (ffi-obj name lib) #f))]) - (if error? obj (ffi-get obj type))))])) -(define-syntax (get-ffi-obj stx) - (syntax-case stx () - [(_ name lib type) - #`(get-ffi-obj* name lib #,(syntax-property #`type 'ffi-name #'name))] - [(_ name lib type failure) - #`(get-ffi-obj* name lib #,(syntax-property #`type 'ffi-name #'name) - failure)] - [x (identifier? #'x) #'get-ffi-obj*])) - -;; It is important to use the set-ffi-obj! wrapper because it takes care of -;; keeping a handle on the object -- otherwise, setting a callback hook will -;; crash when the Scheme function is gone. -(provide* (unsafe set-ffi-obj!)) -(define (set-ffi-obj! name lib type new) - (ffi-set! (ffi-obj (get-ffi-obj-name 'set-ffi-obj! name) - (get-ffi-lib-internal lib)) - type new)) - -;; Combining the above two in a `define-c' special form which makes a Scheme -;; `binding', first a `parameter'-like constructor: -(provide* (unsafe make-c-parameter)) -(define (make-c-parameter name lib type) - (let ([obj (ffi-obj (get-ffi-obj-name 'make-c-parameter name) - (get-ffi-lib-internal lib))]) - (case-lambda [() (ffi-get obj type)] - [(new) (ffi-set! obj type new)]))) -;; Then the fake binding syntax, uses the defined identifier to name the -;; object: -(provide* (unsafe define-c)) -(define-syntax (define-c stx) - (syntax-case stx () - [(_ var-name lib-name type-expr) - (with-syntax ([(p) (generate-temporaries (list #'var-name))]) - (namespace-syntax-introduce - #'(begin (define p (make-c-parameter 'var-name lib-name type-expr)) - (define-syntax var-name - (syntax-id-rules (set!) - [(set! var val) (p val)] - [(var . xs) ((p) . xs)] - [var (p)])))))])) - -;; Used to convert strings and symbols to a byte-string that names an object -(define (get-ffi-obj-name who objname) - (cond [(bytes? objname) objname] - [(symbol? objname) (get-ffi-obj-name who (symbol->string objname))] - [(string? objname) (string->bytes/utf-8 objname)] - [else (raise-type-error who "object-name" objname)])) - -;; This table keeps references to values that are set in foreign libraries, to -;; avoid them being GCed. See set-ffi-obj! above. -(define ffi-objects-ref-table (make-hasheq)) - -;; ---------------------------------------------------------------------------- -;; Compile-time support for fun-expanders - -(begin-for-syntax - - ;; The `_fun' macro tears its input apart and reassemble it using pieces from - ;; custom function types (macros). This whole deal needs some work to make - ;; it play nicely with code certificates, so Matthew wrote the following - ;; code. The idea is to create a define-fun-syntax which makes the new - ;; syntax transformer be an object that carries extra information, later used - ;; by `expand-fun-syntax/fun'. - - (define fun-cert-key (gensym)) - - ;; bug in begin-for-syntax (PR7104), see below - (define foo!!! (make-parameter #f)) - (define (expand-fun-syntax/normal fun-stx stx) - ((foo!!!) fun-stx stx)) - - (define-values (make-fun-syntax fun-syntax? - fun-syntax-proc fun-syntax-certifier fun-syntax-name) - (let-values ([(desc make pred? get set!) - (make-struct-type - 'fun-syntax #f 3 0 #f '() (current-inspector) - expand-fun-syntax/normal)]) - (values make pred? - (make-struct-field-accessor get 0 'proc) - (make-struct-field-accessor get 1 'certifier) - (make-struct-field-accessor get 2 'name)))) - - ;; This is used to expand a fun-syntax in a _fun type context. - (define (expand-fun-syntax/fun stx) - (let loop ([stx stx]) - (define (do-expand id id?) ; id? == are we expanding an identifier? - (define v (syntax-local-value id (lambda () #f))) - (define set!-trans? (set!-transformer? v)) - (define proc (if set!-trans? (set!-transformer-procedure v) v)) - (if (and (fun-syntax? proc) (or (not id?) set!-trans?)) - ;; Do essentially the same thing that `local-expand' does. - ;; First, create an "introducer" to mark introduced identifiers: - (let* ([introduce (make-syntax-introducer)] - [expanded - ;; Re-introduce mark related to expansion of `_fun': - (syntax-local-introduce - ;; Re-add mark specific to this expansion, cancelling - ;; some marks applied before expanding (leaving only - ;; introuced syntax marked) - (introduce - ;; Actually expand: - ((fun-syntax-proc proc) - ;; Add mark specific to this expansion: - (introduce - ;; Remove mark related to expansion of `_fun': - (syntax-local-introduce stx)))))]) - ;; Certify based on definition of expander, then loop - ;; to continue expanding: - (loop ((fun-syntax-certifier proc) - expanded fun-cert-key introduce))) - stx)) - (syntax-case stx () - [(id . rest) (identifier? #'id) (do-expand #'id #f)] - [id (identifier? #'id) (do-expand #'id #t)] - [_else stx]))) - - ;; Use module-or-top-identifier=? because we use keywords like `=' and want - ;; to make it possible to play with it at the toplevel. - (define id=? module-or-top-identifier=?) - - (define (split-by key args) - (let loop ([args args] [r (list '())]) - (cond [(null? args) (reverse (map reverse r))] - [(eq? key (car args)) (loop (cdr args) (cons '() r))] - [else (loop (cdr args) - (cons (cons (car args) (car r)) (cdr r)))]))) - - (define (add-renamer body from to) - (with-syntax ([body body] [from from] [to to]) - #'(let-syntax ([to (syntax-id-rules () - [(_?_ . _rest_) (from . _rest_)] [_?_ from])]) - body))) - - (define (custom-type->keys type err) - (define stops (map (lambda (s) (datum->syntax type s #f)) - '(#%app #%top #%datum))) - ;; Expand `type' using expand-fun-syntax/fun - (define orig (expand-fun-syntax/fun type)) - (define (with-arg x) - (syntax-case* x (=>) id=? - [(id => body) (identifier? #'id) - ;; Extract #'body from its context, use a key it needs certification: - (list (syntax-recertify #'id orig #f fun-cert-key) - (syntax-recertify #'body orig #f fun-cert-key))] - [_else x])) - (define (cert-id id) - (syntax-recertify id orig #f fun-cert-key)) - (let ([keys '()]) - (define (setkey! key val . id?) - (cond - [(assq key keys) - (err "bad expansion of custom type (two `~a:'s)" key type)] - [(and (pair? id?) (car id?) (not (identifier? val))) - (err "bad expansion of custom type (`~a:' expects an identifier)" - key type)] - [else (set! keys (cons (cons key val) keys))])) - (let loop ([t orig]) - (define (next rest . args) (apply setkey! args) (loop rest)) - (syntax-case* t (type: expr: bind: 1st-arg: prev-arg: pre: post:) id=? - [(type: t x ...) (next #'(x ...) 'type #'t)] - [(expr: e x ...) (next #'(x ...) 'expr #'e)] - [(bind: id x ...) (next #'(x ...) 'bind (cert-id #'id) #t)] - [(1st-arg: id x ...) (next #'(x ...) '1st (cert-id #'id) #t)] - [(prev-arg: id x ...) (next #'(x ...) 'prev (cert-id #'id) #t)] - ;; in the following two cases pass along orig for recertifying - [(pre: p x ...) (next #'(x ...) 'pre (with-arg #'p))] - [(post: p x ...) (next #'(x ...) 'post (with-arg #'p))] - [() (and (pair? keys) keys)] - [_else #f])))) - - ;; This is used for a normal expansion of fun-syntax, when not in a _fun type - ;; context. - ;; bug in begin-for-syntax (PR7104), see above - ;; should be (define (expand-fun-syntax/normal fun-stx stx) ...) - (foo!!! (lambda (fun-stx stx) - (define (err msg . sub) - (apply raise-syntax-error (fun-syntax-name fun-stx) msg stx sub)) - (let ([keys (custom-type->keys stx err)]) - (define (getkey key) (cond [(assq key keys) => cdr] [else #f])) - (define (notkey key) - (when (getkey key) - (err (format "this type must be used in a _fun expression (uses ~s)" - key)))) - (if keys - (let ([type (getkey 'type)] [pre (getkey 'pre)] [post (getkey 'post)]) - (unless type - (err "this type must be used in a _fun expression (#f type)")) - (for-each notkey '(expr bind 1st prev)) - (if (or pre post) - ;; a type with pre/post blocks - (let ([make-> (lambda (x what) - (cond [(not x) #'#f] - [(and (list? x) (= 2 (length x)) - (identifier? (car x))) - #`(lambda (#,(car x)) #,(cadr x))] - [else #`(lambda (_) - (error '#,(fun-syntax-name fun-stx) - "cannot be used to ~a" - #,what))]))]) - (with-syntax ([type type] - [scheme->c (make-> pre "send values to C")] - [c->scheme (make-> post "get values from C")]) - #'(make-ctype type scheme->c c->scheme))) - ;; simple type - type)) - ;; no keys => normal expansion - ((fun-syntax-proc fun-stx) stx)))))) - -;; Use define-fun-syntax instead of define-syntax for forms that -;; are to be expanded by `_fun': -(provide define-fun-syntax) -(define-syntax define-fun-syntax - (syntax-rules () - [(_ id trans) - (define-syntax id - (let* ([xformer trans] - [set!-trans? (set!-transformer? xformer)]) - (unless (or (and (procedure? xformer) - (procedure-arity-includes? xformer 1)) - set!-trans?) - (raise-type-error 'define-fun-syntax - "procedure (arity 1) or set!-transformer" - xformer)) - (let ([f (make-fun-syntax (if set!-trans? - (set!-transformer-procedure xformer) - xformer) - ;; Capture definition-time certificates: - (syntax-local-certifier) - 'id)]) - (if set!-trans? (make-set!-transformer f) f))))])) - -;; ---------------------------------------------------------------------------- -;; Function type - -;; Creates a simple function type that can be used for callouts and callbacks, -;; optionally applying a wrapper function to modify the result primitive -;; (callouts) or the input procedure (callbacks). -(define* (_cprocedure itypes otype - #:abi [abi #f] - #:wrapper [wrapper #f] - #:keep [keep #f] - #:atomic? [atomic? #f]) - (_cprocedure* itypes otype abi wrapper keep atomic?)) - -;; for internal use -(define held-callbacks (make-weak-hasheq)) -(define (_cprocedure* itypes otype abi wrapper keep atomic?) - (define-syntax-rule (make-it wrap) - (make-ctype _fpointer - (lambda (x) - (and x - (let ([cb (ffi-callback (wrap x) itypes otype abi atomic?)]) - (cond [(eq? keep #t) (hash-set! held-callbacks x cb)] - [(box? keep) - (let ([x (unbox keep)]) - (set-box! keep - (if (or (null? x) (pair? x)) (cons cb x) cb)))] - [(procedure? keep) (keep cb)]) - cb))) - (lambda (x) (and x (wrap (ffi-call x itypes otype abi)))))) - (if wrapper (make-it wrapper) (make-it begin))) - -;; Syntax for the special _fun type: -;; (_fun [{(name ... [. name]) | name} [-> expr] ::] -;; {type | (name : type [= expr]) | ([name :] type = expr)} ... -;; -> {type | (name : type)} -;; [-> expr]) -;; Usage: -;; `{(name ...) | ...} ::' specify explicit wrapper function formal arguments -;; `-> expr' can be used instead of the last expr -;; `type' input type (implies input, but see type macros next) -;; `(name : type = expr)' specify name and type, `= expr' means computed input -;; `-> type' output type (possibly with name) -;; `-> expr' specify different output, can use previous names -;; Also, see below for custom function types. - -(provide ->) ; to signal better errors when trying to use this with contracts -(define-syntax -> - (syntax-id-rules () - [_ (raise-syntax-error '-> "should be used only in a _fun context")])) - -(provide _fun) -(define-syntax (_fun stx) - (define (err msg . sub) (apply raise-syntax-error '_fun msg stx sub)) - (define xs #f) - (define abi #f) - (define keep #f) - (define atomic? #f) - (define inputs #f) - (define output #f) - (define bind '()) - (define pre '()) - (define post '()) - (define input-names #f) - (define output-type #f) - (define output-expr #f) - (define 1st-arg #f) - (define prev-arg #f) - (define (bind! x) (set! bind (append bind (list x)))) - (define (pre! x) (set! pre (append pre (list x)))) - (define (post! x) (set! post (append post (list x)))) - (define ((t-n-e clause) type name expr) - (let ([keys (custom-type->keys type err)]) - (define (getkey key) (cond [(assq key keys) => cdr] [else #f])) - (define (arg x . no-expr?) - (define use-expr? - (and (list? x) (= 2 (length x)) (identifier? (car x)))) - ;; when the current expr is not used with a (x => ...) form, - ;; either check that no expression is given or just make it - ;; disappear from the inputs. - (unless use-expr? - (if (and (pair? no-expr?) (car no-expr?) expr) - (err "got an expression for a custom type that do not use it" - clause) - (set! expr (void)))) - (set! x (if use-expr? (add-renamer (cadr x) name (car x)) x)) - (cond [(getkey '1st) => - (lambda (v) - (if 1st-arg - (set! x (add-renamer x 1st-arg v)) - (err "got a custom type that wants 1st arg too early" - clause)))]) - (cond [(getkey 'prev) => - (lambda (v) - (if prev-arg - (set! x (add-renamer x prev-arg v)) - (err "got a custom type that wants prev arg too early" - clause)))]) - x) - (when keys - (set! type (getkey 'type)) - (cond [(and (not expr) (getkey 'expr)) => (lambda (x) (set! expr x))]) - (cond [(getkey 'bind) => (lambda (x) (bind! #`[#,x #,name]))]) - (cond [(getkey 'pre) => (lambda (x) (pre! #`[#,name #,(arg x #t)]))]) - (cond [(getkey 'post) => (lambda (x) (post! #`[#,name #,(arg x)]))])) - ;; turn a #f syntax to #f - (set! type (and type (syntax-case type () [#f #f] [_ type]))) - (when type ; remember these for later usages - (unless 1st-arg (set! 1st-arg name)) - (set! prev-arg name)) - (list type name expr))) - (define (do-fun) - ;; parse keywords - (let loop () - (let ([k (and (pair? xs) (pair? (cdr xs)) (syntax-e (car xs)))]) - (define-syntax-rule (kwds [key var] ...) - (case k - [(key) (if var - (err (format "got a second ~s keyword") 'key (car xs)) - (begin (set! var (cadr xs)) (set! xs (cddr xs)) (loop)))] - ... - [else (err "unknown keyword" (car xs))])) - (when (keyword? k) (kwds [#:abi abi] [#:keep keep] [#:atomic? atomic?])))) - (unless abi (set! abi #'#f)) - (unless keep (set! keep #'#t)) - (unless atomic? (set! atomic? #'#f)) - ;; parse known punctuation - (set! xs (map (lambda (x) - (syntax-case* x (-> ::) id=? [:: '::] [-> '->] [_ x])) - xs)) - ;; parse "::" - (let ([s (split-by ':: xs)]) - (case (length s) - [(0) (err "something bad happened (::)")] - [(1) (void)] - [(2) (if (and (= 1 (length (car s))) (not (eq? '-> (caar s)))) - (begin (set! xs (cadr s)) (set! input-names (caar s))) - (err "bad wrapper formals"))] - [else (err "saw two or more instances of `::'")])) - ;; parse "->" - (let ([s (split-by '-> xs)]) - (case (length s) - [(0) (err "something bad happened (->)")] - [(1) (err "missing output type")] - [(2 3) (set! inputs (car s)) - (case (length (cadr s)) - [(1) (set! output-type (caadr s))] - [(0) (err "missing output type after `->'")] - [else (err "extraneous output type" (cadadr s))]) - (unless (null? (cddr s)) - (case (length (caddr s)) - [(1) (set! output-expr (caaddr s))] - [(0) (err "missing output expression after `->'")] - [else (err "extraneous output expression" - (cadr (caddr s)))]))] - [else (err "saw three or more instances of `->'")])) - (set! inputs - (map (lambda (sub temp) - (let ([t-n-e (t-n-e sub)]) - (syntax-case* sub (: =) id=? - [(name : type) (t-n-e #'type #'name #f)] - [(type = expr) (t-n-e #'type temp #'expr)] - [(name : type = expr) (t-n-e #'type #'name #'expr)] - [type (t-n-e #'type temp #f)]))) - inputs - (generate-temporaries (map (lambda (x) 'tmp) inputs)))) - ;; when processing the output type, only the post code matters - (set! pre! (lambda (x) #f)) - (set! output - (let ([temp (car (generate-temporaries #'(ret)))] - [t-n-e (t-n-e output-type)]) - (syntax-case* output-type (: =) id=? - [(name : type) (t-n-e #'type #'name output-expr)] - [(type = expr) (if output-expr - (err "extraneous output expression" #'expr) - (t-n-e #'type temp #'expr))] - [(name : type = expr) - (if output-expr - (err "extraneous output expression" #'expr) - (t-n-e #'type #'name #'expr))] - [type (t-n-e #'type temp output-expr)]))) - (if (or (caddr output) input-names (ormap caddr inputs) - (ormap (lambda (x) (not (car x))) inputs) - (pair? bind) (pair? pre) (pair? post)) - (let* ([input-names (or input-names - (filter-map (lambda (i) - (and (not (caddr i)) (cadr i))) - inputs))] - [output-expr (let ([o (caddr output)]) - (or (and (not (void? o)) o) - (cadr output)))] - [args (filter-map (lambda (i) - (and (caddr i) - (not (void? (caddr i))) - #`[#,(cadr i) #,(caddr i)])) - inputs)] - [ffi-args (filter-map (lambda (x) (and (car x) (cadr x))) inputs)] - ;; the actual wrapper body - [body (quasisyntax/loc stx - (lambda #,input-names - (let* (#,@args - #,@bind - #,@pre - [#,(cadr output) (ffi #,@ffi-args)] - #,@post) - #,output-expr)))] - ;; if there is a string 'ffi-name property, use it as a name - [body (let ([n (cond [(syntax-property stx 'ffi-name) - => syntax->datum] - [else #f])]) - (if (string? n) - (syntax-property - body 'inferred-name - (string->symbol (string-append "ffi-wrapper:" n))) - body))]) - #`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output) - #,abi (lambda (ffi) #,body) #,keep #,atomic?)) - #`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output) - #,abi #f #,keep #,atomic?))) - (syntax-case stx () - [(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))])) - -(define (function-ptr p fun-ctype) - (if (or (cpointer? p) (procedure? p)) - (if (eq? (ctype->layout fun-ctype) 'fpointer) - (if (procedure? p) - ((ctype-scheme->c fun-ctype) p) - ((ctype-c->scheme fun-ctype) p)) - (raise-type-error 'function-ptr "function ctype" fun-ctype)) - (raise-type-error 'function-ptr "cpointer" p))) - -;; ---------------------------------------------------------------------------- -;; String types - -;; The internal _string type uses the native ucs-4 encoding, also providing a -;; utf-16 type -(provide _string/ucs-4 _string/utf-16) - -;; 8-bit string encodings, #f is NULL -(define ((false-or-op op) x) (and x (op x))) -(define* _string/utf-8 - (make-ctype _bytes - (false-or-op string->bytes/utf-8) (false-or-op bytes->string/utf-8))) -(define* _string/locale - (make-ctype _bytes - (false-or-op string->bytes/locale) (false-or-op bytes->string/locale))) -(define* _string/latin-1 - (make-ctype _bytes - (false-or-op string->bytes/latin-1) (false-or-op bytes->string/latin-1))) - -;; 8-bit string encodings, #f is NULL, can also use bytes and paths -(define ((any-string-op op) x) - (cond [(not x) x] - [(bytes? x) x] - [(path? x) (path->bytes x)] - [else (op x)])) -(define* _string*/utf-8 - (make-ctype _bytes - (any-string-op string->bytes/utf-8) (false-or-op bytes->string/utf-8))) -(define* _string*/locale - (make-ctype _bytes - (any-string-op string->bytes/locale) (false-or-op bytes->string/locale))) -(define* _string*/latin-1 - (make-ctype _bytes - (any-string-op string->bytes/latin-1) (false-or-op bytes->string/latin-1))) - -;; A generic _string type that usually does the right thing via a parameter -(define* default-_string-type - (make-parameter _string*/utf-8 - (lambda (x) - (if (ctype? x) - x (error 'default-_string-type "expecting a C type, got ~e" x))))) -;; The type looks like an identifier, but it's actually using the parameter -(provide _string) -(define-syntax _string - (syntax-id-rules () - [(_ . xs) ((default-_string-type) . xs)] - [_ (default-_string-type)])) - -;; _symbol is defined in C, since it uses simple C strings -(provide _symbol) - -(provide _path) -;; `file' type: path-expands a path string, provide _path too. -(define* _file (make-ctype _path cleanse-path #f)) - -;; `string/eof' type: converts an output #f (NULL) to an eof-object. -(define string-type->string/eof-type - (let ([table (make-hasheq)]) - (lambda (string-type) - (hash-ref table string-type - (lambda () - (let ([new-type (make-ctype string-type - (lambda (x) (and (not (eof-object? x)) x)) - (lambda (x) (or x eof)))]) - (hash-set! table string-type new-type) - new-type)))))) -(provide _string/eof _bytes/eof) -(define _bytes/eof - (make-ctype _bytes - (lambda (x) (and (not (eof-object? x)) x)) - (lambda (x) (or x eof)))) -(define-syntax _string/eof ; make it a syntax so it depends on the _string type - (syntax-id-rules () - [(_ . xs) ((string-type->string/eof-type _string) . xs)] - [_ (string-type->string/eof-type _string)])) - -;; ---------------------------------------------------------------------------- -;; Utility types - -;; Call this with a name (symbol) and a list of symbols, where a symbol can be -;; followed by a '= and an integer to have a similar effect of C's enum. -(define (_enum* name symbols . base?) - (define basetype (if (pair? base?) (car base?) _ufixint)) - (define sym->int '()) - (define int->sym '()) - (define s->c - (if name (string->symbol (format "enum:~a->int" name)) 'enum->int)) - (let loop ([i 0] [symbols symbols]) - (unless (null? symbols) - (let-values ([(i rest) - (if (and (pair? (cdr symbols)) - (eq? '= (cadr symbols)) - (pair? (cddr symbols))) - (values (caddr symbols) - (cdddr symbols)) - (values i - (cdr symbols)))]) - (set! sym->int (cons (cons (car symbols) i) sym->int)) - (set! int->sym (cons (cons i (car symbols)) int->sym)) - (loop (add1 i) rest)))) - (make-ctype basetype - (lambda (x) - (let ([a (assq x sym->int)]) - (if a - (cdr a) - (raise-type-error s->c (format "~a" (or name "enum")) x)))) - (lambda (x) (cond [(assq x int->sym) => cdr] [else #f])))) - -;; Macro wrapper -- no need for a name -(provide _enum) -(define-syntax (_enum stx) - (syntax-case stx () - [(_ syms) - (with-syntax ([name (syntax-local-name)]) - #'(_enum* 'name syms))] - [(_ syms basetype) - (with-syntax ([name (syntax-local-name)]) - #'(_enum* 'name syms basetype))] - [id (identifier? #'id) - #'(lambda (syms . base?) (apply _enum* #f syms base?))])) - -;; Call this with a name (symbol) and a list of (symbol int) or symbols like -;; the above with '= -- but the numbers have to be specified in some way. The -;; generated type will convert a list of these symbols into the logical-or of -;; their values and back. -(define (_bitmask* name orig-symbols->integers . base?) - (define basetype (if (pair? base?) (car base?) _uint)) - (define s->c - (if name (string->symbol (format "bitmask:~a->int" name)) 'bitmask->int)) - (define symbols->integers - (let loop ([s->i orig-symbols->integers]) - (cond - [(null? s->i) - null] - [(and (pair? (cdr s->i)) (eq? '= (cadr s->i)) (pair? (cddr s->i))) - (cons (list (car s->i) (caddr s->i)) - (loop (cdddr s->i)))] - [(and (pair? (car s->i)) (pair? (cdar s->i)) (null? (cddar s->i)) - (symbol? (caar s->i)) (integer? (cadar s->i))) - (cons (car s->i) (loop (cdr s->i)))] - [else - (error '_bitmask "bad spec in ~e" orig-symbols->integers)]))) - (make-ctype basetype - (lambda (symbols) - (if (null? symbols) ; probably common - 0 - (let loop ([xs (if (pair? symbols) symbols (list symbols))] [n 0]) - (cond [(null? xs) n] - [(assq (car xs) symbols->integers) => - (lambda (x) (loop (cdr xs) (bitwise-ior (cadr x) n)))] - [else (raise-type-error s->c (format "~a" (or name "bitmask")) - symbols)])))) - (lambda (n) - (if (zero? n) ; probably common - '() - (let loop ([s->i symbols->integers] [l '()]) - (if (null? s->i) - (reverse l) - (loop (cdr s->i) - (let ([i (cadar s->i)]) - (if (and (not (= i 0)) (= i (bitwise-and i n))) - (cons (caar s->i) l) - l))))))))) - -;; Macro wrapper -- no need for a name -(provide _bitmask) -(define-syntax (_bitmask stx) - (syntax-case stx () - [(_ syms) - (with-syntax ([name (syntax-local-name)]) - #'(_bitmask* 'name syms))] - [(_ syms basetype) - (with-syntax ([name (syntax-local-name)]) - #'(_bitmask* 'name syms basetype))] - [id (identifier? #'id) - #'(lambda (syms . base?) (apply _bitmask* #f syms base?))])) - -;; ---------------------------------------------------------------------------- -;; Custom function type macros - -;; These macros get expanded by the _fun type. They can expand to a form that -;; looks like (keyword: value ...), where the keyword is one of: -;; * `type:' for the type that will be used, -;; * `expr:' an expression that will always be used for these arguments, as -;; if `= expr' is always given, when an expression is actually -;; given in an argument specification, it supersedes this. -;; * `bind:' for an additional binding that holds the initial value, -;; * `1st-arg:' is used to name an identifier that will be bound to the value -;; of the 1st foreign argument in pre/post chunks (good for -;; common cases where the first argument has a special meaning, -;; eg, for method calls), -;; * `prev-arg:' similar to 1st-arg: but for the previous argument, -;; * `pre:' for a binding that will be inserted before the ffi call, -;; * `post:' for a binding after the ffi call. -;; The pre: and post: bindings can be of the form (id => expr) to use the -;; existing value. Note that if the pre: expression is not (id => expr), then -;; it means that there is no input for this argument. Also note that if a -;; custom type is used as an output type of a function, then only the post: -;; code is used -- for example, this is useful for foreign functions that -;; allocate a memory block and return it to the user. The resulting wrapper -;; looks like: -;; (let* (...bindings for arguments... -;; ...bindings for bind: identifiers... -;; ...bindings for pre-code... -;; (ret-name ffi-call) -;; ...bindings for post-code...) -;; return-expression) -;; -;; Finally, the code in a custom-function macro needs special treatment when it -;; comes to dealing with code certificates, so instead of using -;; `define-syntax', you should use `define-fun-syntax' (used in the same way). - -;; _? -;; This is not a normal ffi type -- it is a marker for expressions that should -;; not be sent to the ffi function. Use this to bind local values in a -;; computation that is part of an ffi wrapper interface. -(provide _?) -(define-fun-syntax _? - (syntax-id-rules () [(_ . xs) ((type: #f) . xs)] [_ (type: #f)])) - -;; (_ptr ) -;; This is for pointers, where mode indicates input or output pointers (or -;; both). If the mode is `o' (output), then the wrapper will not get an -;; argument for it, instead it generates the matching argument. -(provide _ptr) -(define-fun-syntax _ptr - (syntax-rules (i o io) - [(_ i t) (type: _pointer - pre: (x => (let ([p (malloc t)]) (ptr-set! p t x) p)))] - [(_ o t) (type: _pointer - pre: (malloc t) - post: (x => (ptr-ref x t)))] - [(_ io t) (type: _pointer - pre: (x => (let ([p (malloc t)]) (ptr-set! p t x) p)) - post: (x => (ptr-ref x t)))])) - -;; (_box ) -;; This is similar to a (_ptr io ) argument, where the input is expected -;; to be a box, which is unboxed on entry and modified on exit. -(provide _box) -(define-fun-syntax _box - (syntax-rules () - [(_ t) (type: _pointer - bind: tmp ; need to save the box so we can get back to it - pre: (x => (let ([p (malloc t)]) (ptr-set! p t (unbox x)) p)) - post: (x => (begin (set-box! tmp (ptr-ref x t)) tmp)))])) - -;; (_list []) -;; Similar to _ptr, except that it is used for converting lists to/from C -;; vectors. The length is needed for output values where it is used in the -;; post code, and in the pre code of an output mode to allocate the block. In -;; any case it can refer to a previous binding for the length of the list which -;; the C function will most likely require. -(provide _list) -(define-fun-syntax _list - (syntax-rules (i o io) - [(_ i t ) (type: _pointer - pre: (x => (list->cblock x t)))] - [(_ o t n) (type: _pointer - pre: (malloc n t) - post: (x => (cblock->list x t n)))] - [(_ io t n) (type: _pointer - pre: (x => (list->cblock x t)) - post: (x => (cblock->list x t n)))])) - -;; (_vector []) -;; Same as _list, except that it uses Scheme vectors. -(provide _vector) -(define-fun-syntax _vector - (syntax-rules (i o io) - [(_ i t ) (type: _pointer - pre: (x => (vector->cblock x t)))] - [(_ o t n) (type: _pointer - pre: (malloc n t) - post: (x => (cblock->vector x t n)))] - [(_ io t n) (type: _pointer - pre: (x => (vector->cblock x t)) - post: (x => (cblock->vector x t n)))])) - -;; _bytes or (_bytes o n) is for a memory block represented as a Scheme byte -;; string. _bytes is just like a byte-string, and (_bytes o n) is for -;; pre-malloc of the string. There is no need for other modes: i or io would -;; be just like _bytes since the string carries its size information (so there -;; is no real need for the `o', but it's there for consistency with the above -;; macros). -(provide (rename-out [_bytes* _bytes])) -(define-fun-syntax _bytes* - (syntax-id-rules (o) - [(_ o n) (type: _bytes - pre: (make-sized-byte-string (malloc n) n) - ;; post is needed when this is used as a function output type - post: (x => (make-sized-byte-string x n)))] - [(_ . xs) (_bytes . xs)] - [_ _bytes])) - -;; ---------------------------------------------------------------------------- -;; Safe raw vectors - -(define-struct cvector (ptr type length)) - -(provide* cvector? cvector-length cvector-type cvector-ptr - ;; make-cvector* is a dangerous operation - (unsafe (rename-out [make-cvector make-cvector*]))) - -(define _cvector* ; used only as input types - (make-ctype _pointer cvector-ptr - (lambda (x) - (error '_cvector - "cannot automatically convert a C pointer to a cvector")))) - -;; (_cvector [ ]) | _cevector -;; Same as _list etc above, except that it uses C vectors. -(provide _cvector) -(define-fun-syntax _cvector - (syntax-id-rules (i o io) - [(_ i ) _cvector*] - [(_ o t n) (type: _pointer ; needs to be a pointer, not a cvector* - pre: (malloc n t) - post: (x => (make-cvector x t n)))] - [(_ io ) (type: _cvector* - bind: tmp - pre: (x => (cvector-ptr x)) - post: (x => tmp))] - [(_ . xs) (_cvector* . xs)] - [_ _cvector*])) - -(provide (rename-out [allocate-cvector make-cvector])) -(define (allocate-cvector type len) - (make-cvector (if (zero? len) #f ; 0 => NULL - (malloc len type)) - type len)) - -(provide (rename-out [cvector-args cvector])) -(define (cvector-args type . args) - (list->cvector args type)) - -(define* (cvector-ref v i) - (if (and (exact-nonnegative-integer? i) (< i (cvector-length v))) - (ptr-ref (cvector-ptr v) (cvector-type v) i) - (error 'cvector-ref "bad index ~e for cvector bounds of 0..~e" - i (sub1 (cvector-length v))))) - -(define* (cvector-set! v i x) - (if (and (exact-nonnegative-integer? i) (< i (cvector-length v))) - (ptr-set! (cvector-ptr v) (cvector-type v) i x) - (error 'cvector-ref "bad index ~e for cvector bounds of 0..~e" - i (sub1 (cvector-length v))))) - -(define* (cvector->list v) - (cblock->list (cvector-ptr v) (cvector-type v) (cvector-length v))) - -(define* (list->cvector l type) - (make-cvector (list->cblock l type) type (length l))) - -;; ---------------------------------------------------------------------------- -;; SRFI-4 implementation - -(define-syntax (srfi-4-define/provide stx) - (syntax-case stx () - [(_ TAG type) - (identifier? #'TAG) - (let ([name (format "~avector" (syntax->datum #'TAG))]) - (define (id prefix suffix) - (let* ([name (if prefix (string-append prefix name) name)] - [name (if suffix (string-append name suffix) name)]) - (datum->syntax #'TAG (string->symbol name) #'TAG))) - (with-syntax ([TAG? (id "" "?")] - [TAG (id "" "")] - [s:TAG (id "s:" "")] - [make-TAG (id "make-" "")] - [TAG-ptr (id "" "-ptr")] - [TAG-length (id "" "-length")] - [allocate-TAG (id "allocate-" "")] - [TAG* (id "" "*")] - [list->TAG (id "list->" "")] - [TAG->list (id "" "->list")] - [TAG-ref (id "" "-ref")] - [TAG-set! (id "" "-set!")] - [_TAG (id "_" "")] - [_TAG* (id "_" "*")] - [TAGname name]) - #'(begin - (define-struct TAG (ptr length)) - (provide TAG? TAG-length (rename-out [TAG s:TAG])) - (provide (rename-out [allocate-TAG make-TAG])) - (define (allocate-TAG n . init) - (let* ([p (if (eq? n 0) #f (malloc n type))] - [v (make-TAG p n)]) - (when (and p (pair? init)) - (let ([init (car init)]) - (let loop ([i (sub1 n)]) - (unless (< i 0) - (ptr-set! p type i init) - (loop (sub1 i)))))) - v)) - (provide (rename-out [TAG* TAG])) - (define (TAG* . vals) - (list->TAG vals)) - (define* (TAG-ref v i) - (if (TAG? v) - (if (and (exact-nonnegative-integer? i) (< i (TAG-length v))) - (ptr-ref (TAG-ptr v) type i) - (error 'TAG-ref "bad index ~e for ~a bounds of 0..~e" - i 'TAG (sub1 (TAG-length v)))) - (raise-type-error 'TAG-ref TAGname v))) - (define* (TAG-set! v i x) - (if (TAG? v) - (if (and (exact-nonnegative-integer? i) (< i (TAG-length v))) - (ptr-set! (TAG-ptr v) type i x) - (error 'TAG-set! "bad index ~e for ~a bounds of 0..~e" - i 'TAG (sub1 (TAG-length v)))) - (raise-type-error 'TAG-set! TAGname v))) - (define* (TAG->list v) - (if (TAG? v) - (cblock->list (TAG-ptr v) type (TAG-length v)) - (raise-type-error 'TAG->list TAGname v))) - (define* (list->TAG l) - (make-TAG (list->cblock l type) (length l))) - ;; same as the _cvector implementation - (provide _TAG) - (define _TAG* - (make-ctype _pointer TAG-ptr - (lambda (x) - (error - '_TAG - "cannot automatically convert a C pointer to a ~a" - TAGname)))) - (define-fun-syntax _TAG - (syntax-id-rules (i o io) - [(_ i ) _TAG*] - [(_ o n) (type: _pointer - pre: (malloc n type) - post: (x => (make-TAG x n)))] - [(_ io ) (type: _cvector* - bind: tmp - pre: (x => (TAG-ptr x)) - post: (x => tmp))] - [(_ . xs) (_TAG* . xs)] - [_ _TAG*])))))] - [(_ TAG type) - (identifier? #'TAG)])) - -;; check that the types that were used above have the proper sizes -(unless (= 4 (ctype-sizeof _float)) - (error 'foreign "internal error: float has a bad size (~s)" - (ctype-sizeof _float))) -(unless (= 8 (ctype-sizeof _double*)) - (error 'foreign "internal error: double has a bad size (~s)" - (ctype-sizeof _double*))) - -(srfi-4-define/provide s8 _int8) -(srfi-4-define/provide s16 _int16) -(srfi-4-define/provide u16 _uint16) -(srfi-4-define/provide s32 _int32) -(srfi-4-define/provide u32 _uint32) -(srfi-4-define/provide s64 _int64) -(srfi-4-define/provide u64 _uint64) -(srfi-4-define/provide f32 _float) -(srfi-4-define/provide f64 _double*) - -;; simply rename bytes* to implement the u8vector type -(provide (rename-out [bytes? u8vector? ] - [bytes-length u8vector-length] - [make-bytes make-u8vector ] - [bytes u8vector ] - [bytes-ref u8vector-ref ] - [bytes-set! u8vector-set! ] - [bytes->list u8vector->list ] - [list->bytes list->u8vector ] - [_bytes _u8vector ])) -;; additional `u8vector' bindings for srfi-66 -(provide (rename-out [bytes-copy u8vector-copy] [bytes=? u8vector=?])) -(define* (u8vector-compare v1 v2) - (cond [(bytes? v1 v2) 1] - [else 0])) -(define* (u8vector-copy! src src-start dest dest-start n) - (bytes-copy! dest dest-start src src-start (+ src-start n))) - -;; ---------------------------------------------------------------------------- -;; Tagged pointers - -;; Make these operations available for unsafe interfaces (they can be used to -;; grab a hidden tag value and break code). -(provide* (unsafe cpointer-tag) (unsafe set-cpointer-tag!) - (unsafe cpointer-has-tag?) (unsafe cpointer-push-tag!)) - -;; Defined as syntax for efficiency, but can be used as procedures too. -(define-syntax (cpointer-has-tag? stx) - (syntax-case stx () - [(_ cptr tag) - #'(let ([ptag (cpointer-tag cptr)]) - (if (pair? ptag) (memq tag ptag) (eq? tag ptag)))] - [id (identifier? #'id) - #'(lambda (cptr tag) (cpointer-has-tag? cptr tag))])) -(define-syntax (cpointer-push-tag! stx) - (syntax-case stx () - [(_ cptr tag) - #'(let ([ptag (cpointer-tag cptr)]) - (set-cpointer-tag! cptr - (cond [(not ptag) tag] - [(pair? ptag) (cons tag ptag)] - [else (list tag ptag)])))] - [id (identifier? #'id) - #'(lambda (cptr tag) (cpointer-push-tag! cptr tag))])) - -(define (cpointer-maker nullable?) - (case-lambda - [(tag) ((cpointer-maker nullable?) tag #f #f #f)] - [(tag ptr-type) ((cpointer-maker nullable?) tag ptr-type #f #f)] - [(tag ptr-type scheme->c c->scheme) - (let* ([tag->C (string->symbol (format "~a->C" tag))] - [error-str (format "~a`~a' pointer" - (if nullable? "" "non-null ") tag)] - [error* (lambda (p) (raise-type-error tag->C error-str p))]) - (define-syntax-rule (tag-or-error ptr t) - (let ([p ptr]) - (if (cpointer? p) - (if (cpointer-has-tag? p t) p (error* p)) - (error* p)))) - (define-syntax-rule (tag-or-error/null ptr t) - (let ([p ptr]) - (if (cpointer? p) - (and p (if (cpointer-has-tag? p t) p (error* p))) - (error* p)))) - (make-ctype (or ptr-type _pointer) - ;; bad hack: `if's outside the lambda for efficiency - (if nullable? - (if scheme->c - (lambda (p) (tag-or-error/null (scheme->c p) tag)) - (lambda (p) (tag-or-error/null p tag))) - (if scheme->c - (lambda (p) (tag-or-error (scheme->c p) tag)) - (lambda (p) (tag-or-error p tag)))) - (if nullable? - (if c->scheme - (lambda (p) (when p (cpointer-push-tag! p tag)) (c->scheme p)) - (lambda (p) (when p (cpointer-push-tag! p tag)) p)) - (if c->scheme - (lambda (p) - (if p (cpointer-push-tag! p tag) (error* p)) - (c->scheme p)) - (lambda (p) - (if p (cpointer-push-tag! p tag) (error* p)) - p)))))])) - -;; This is a kind of a pointer that gets a specific tag when converted to -;; Scheme, and accepts only such tagged pointers when going to C. An optional -;; `ptr-type' can be given to be used as the base pointer type, instead of -;; _pointer, `scheme->c' and `c->scheme' can be used for adding conversion -;; hooks. -(define* _cpointer (cpointer-maker #f)) - -;; Similar to the above, but can tolerate null pointers (#f). -(define* _cpointer/null (cpointer-maker #t)) - -;; A macro version of the above two functions, using the defined name for a tag -;; string, and defining a predicate too. The name should look like `_foo', the -;; predicate will be `foo?', and the tag will be "foo". In addition, `foo-tag' -;; is bound to the tag. The optional `ptr-type', `scheme->c', and `c->scheme' -;; arguments are the same as those of `_cpointer'. `_foo' will be bound to the -;; _cpointer type, and `_foo/null' to the _cpointer/null type. -(provide define-cpointer-type) -(define-syntax (define-cpointer-type stx) - (syntax-case stx () - [(_ _TYPE) #'(define-cpointer-type _TYPE #f #f #f)] - [(_ _TYPE ptr-type) #'(define-cpointer-type _TYPE ptr-type #f #f)] - [(_ _TYPE ptr-type scheme->c c->scheme) - (and (identifier? #'_TYPE) - (regexp-match #rx"^_.+" (symbol->string (syntax-e #'_TYPE)))) - (let ([name (cadr (regexp-match #rx"^_(.+)$" - (symbol->string (syntax-e #'_TYPE))))]) - (define (id . strings) - (datum->syntax - #'_TYPE (string->symbol (apply string-append strings)) #'_TYPE)) - (with-syntax ([name-string name] - [TYPE? (id name "?")] - [TYPE-tag (id name "-tag")] - [_TYPE/null (id "_" name "/null")]) - #'(define-values (_TYPE _TYPE/null TYPE? TYPE-tag) - (let ([TYPE-tag name-string]) - (values (_cpointer TYPE-tag ptr-type scheme->c c->scheme) - (_cpointer/null TYPE-tag ptr-type scheme->c c->scheme) - (lambda (x) - (and (cpointer? x) (cpointer-has-tag? x TYPE-tag))) - TYPE-tag)))))])) - -;; ---------------------------------------------------------------------------- -;; Struct wrappers - -(define (compute-offsets types) - (let loop ([ts types] [cur 0] [r '()]) - (if (null? ts) - (reverse r) - (let* ([algn (ctype-alignof (car ts))] - [pos (+ cur (modulo (- (modulo cur algn)) algn))]) - (loop (cdr ts) - (+ pos (ctype-sizeof (car ts))) - (cons pos r)))))) - -;; Simple structs: call this with a list of types, and get a type that marshals -;; C structs to/from Scheme lists. -(define* (_list-struct . types) - (let ([stype (make-cstruct-type types)] - [offsets (compute-offsets types)] - [len (length types)]) - (make-ctype stype - (lambda (vals) - (unless (and (list vals) (= len (length vals))) - (raise-type-error 'list-struct (format "list of ~a items" len) vals)) - (let ([block (malloc stype)]) - (for-each (lambda (type ofs val) (ptr-set! block type 'abs ofs val)) - types offsets vals) - block)) - (lambda (block) - (map (lambda (type ofs) (ptr-ref block type 'abs ofs)) - types offsets))))) - -;; (define-cstruct _foo ([slot type] ...)) -;; or -;; (define-cstruct (_foo _super) ([slot type] ...)) -;; defines a type called _foo for a C struct, with user-procedues: make-foo, -;; foo? foo-slot... and set-foo-slot!.... The `_' prefix is required. Objects -;; of this new type are actually cpointers, with a type tag that is "foo" and -;; (possibly more if the first type is itself a cstruct type or if a super type -;; is given,) provided as foo-tag, and tags of pointers are checked before -;; attempting to use them (see define-cpointer-type above). Note that since -;; structs are implemented as pointers, they can be used for a _pointer input -;; to a foreign function: their address will be used, to make this possible, -;; the corresponding cpointer type is defined as _foo-pointer. If a super -;; cstruct type is given, the constructor function expects values for every -;; field of the super type as well as other fields that are specified, and a -;; slot named `super' can be used to extract this initial struct -- although -;; pointers to the new struct type can be used as pointers to the super struct -;; type. -(provide define-cstruct) -(define-syntax (define-cstruct stx) - (define (make-syntax _TYPE-stx has-super? slot-names-stx slot-types-stx) - (define name - (cadr (regexp-match #rx"^_(.+)$" (symbol->string (syntax-e _TYPE-stx))))) - (define slot-names (map (lambda (x) (symbol->string (syntax-e x))) - (syntax->list slot-names-stx))) - (define 1st-type - (let ([xs (syntax->list slot-types-stx)]) (and (pair? xs) (car xs)))) - (define (id . strings) - (datum->syntax - _TYPE-stx (string->symbol (apply string-append strings)) _TYPE-stx)) - (define (ids name-func) - (map (lambda (s) - (datum->syntax - _TYPE-stx - (string->symbol (apply string-append (name-func s))) - _TYPE-stx)) - slot-names)) - (define (safe-id=? x y) - (and (identifier? x) (identifier? y) (free-identifier=? x y))) - (with-syntax - ([has-super? has-super?] - [name-string name] - [struct-string (format "struct:~a" name)] - [(slot ...) slot-names-stx] - [(slot-type ...) slot-types-stx] - [_TYPE _TYPE-stx] - [_TYPE-pointer (id "_"name"-pointer")] - [_TYPE-pointer/null (id "_"name"-pointer/null")] - [_TYPE/null (id "_"name"/null")] - [_TYPE* (id "_"name"*")] - [TYPE? (id name"?")] - [make-TYPE (id "make-"name)] - [list->TYPE (id "list->"name)] - [list*->TYPE (id "list*->"name)] - [TYPE->list (id name"->list")] - [TYPE->list* (id name"->list*")] - [TYPE-tag (id name"-tag")] - [(stype ...) (ids (lambda (s) `(,name"-",s"-type")))] - [(TYPE-SLOT ...) (ids (lambda (s) `(,name"-",s)))] - [(set-TYPE-SLOT! ...) (ids (lambda (s) `("set-",name"-",s"!")))] - [(offset ...) (generate-temporaries - (ids (lambda (s) `(,s"-offset"))))]) - (with-syntax ([get-super-info - ;; the 1st-type might be a pointer to this type - (if (or (safe-id=? 1st-type #'_TYPE-pointer/null) - (safe-id=? 1st-type #'_TYPE-pointer)) - #'(values #f '() #f #f #f #f) - #`(cstruct-info #,1st-type - (lambda () (values #f '() #f #f #f #f))))]) - #'(define-values (_TYPE _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag - make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ... - list->TYPE list*->TYPE TYPE->list TYPE->list*) - (let-values ([(super-pointer super-tags super-types super-offsets - super->list* list*->super) - get-super-info]) - (define-cpointer-type _TYPE super-pointer) - ;; these makes it possible to use recursive pointer definitions - (define _TYPE-pointer _TYPE) - (define _TYPE-pointer/null _TYPE/null) - (let*-values ([(stype ...) (values slot-type ...)] - [(types) (list stype ...)] - [(offsets) (compute-offsets types)] - [(offset ...) (apply values offsets)]) - (define all-tags (cons TYPE-tag super-tags)) - (define _TYPE* - ;; c->scheme adjusts all tags - (let* ([cst (make-cstruct-type types)] - [t (_cpointer TYPE-tag cst)] - [c->s (ctype-c->scheme t)]) - (make-ctype cst (ctype-scheme->c t) - ;; hack: modify & reuse the procedure made by _cpointer - (lambda (p) - (if p (set-cpointer-tag! p all-tags) (c->s p)) - p)))) - (define-values (all-types all-offsets) - (if (and has-super? super-types super-offsets) - (values (append super-types (cdr types)) - (append super-offsets (cdr offsets))) - (values types offsets))) - (define (TYPE-SLOT x) - (unless (TYPE? x) - (raise-type-error 'TYPE-SLOT struct-string x)) - (ptr-ref x stype 'abs offset)) - ... - (define (set-TYPE-SLOT! x slot) - (unless (TYPE? x) - (raise-type-error 'set-TYPE-SLOT! struct-string 0 x slot)) - (ptr-set! x stype 'abs offset slot)) - ... - (define make-TYPE - (if (and has-super? super-types super-offsets) - ;; init using all slots - (lambda vals - (if (= (length vals) (length all-types)) - (let ([block (malloc _TYPE*)]) - (set-cpointer-tag! block all-tags) - (for-each (lambda (type ofs value) - (ptr-set! block type 'abs ofs value)) - all-types all-offsets vals) - block) - (error '_TYPE "expecting ~s values, got ~s: ~e" - (length all-types) (length vals) vals))) - ;; normal initializer - (lambda (slot ...) - (let ([block (malloc _TYPE*)]) - (set-cpointer-tag! block all-tags) - (ptr-set! block stype 'abs offset slot) - ... - block)))) - (define (list->TYPE vals) (apply make-TYPE vals)) - (define (list*->TYPE vals) - (cond - [(TYPE? vals) vals] - [(= (length vals) (length all-types)) - (let ([block (malloc _TYPE*)]) - (set-cpointer-tag! block all-tags) - (for-each - (lambda (type ofs value) - (let-values - ([(ptr tags types offsets T->list* list*->T) - (cstruct-info - type - (lambda () (values #f '() #f #f #f #f)))]) - (ptr-set! block type 'abs ofs - (if list*->T (list*->T value) value)))) - all-types all-offsets vals) - block)] - [else (error '_TYPE "expecting ~s values, got ~s: ~e" - (length all-types) (length vals) vals)])) - (define (TYPE->list x) - (unless (TYPE? x) - (raise-type-error 'TYPE-list struct-string x)) - (map (lambda (type ofs) (ptr-ref x type 'abs ofs)) - all-types all-offsets)) - (define (TYPE->list* x) - (unless (TYPE? x) - (raise-type-error 'TYPE-list struct-string x)) - (map (lambda (type ofs) - (let-values - ([(v) (ptr-ref x type 'abs ofs)] - [(ptr tags types offsets T->list* list*->T) - (cstruct-info - type - (lambda () (values #f '() #f #f #f #f)))]) - (if T->list* (T->list* v) v))) - all-types all-offsets)) - (cstruct-info - _TYPE* 'set! - _TYPE all-tags all-types all-offsets TYPE->list* list*->TYPE) - (values _TYPE* _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag - make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ... - list->TYPE list*->TYPE TYPE->list TYPE->list*))))))) - (define (identifiers? stx) - (andmap identifier? (syntax->list stx))) - (define (_-identifier? id stx) - (and (identifier? id) - (or (regexp-match #rx"^_." (symbol->string (syntax-e id))) - (raise-syntax-error #f "cstruct name must begin with a `_'" - stx id)))) - (syntax-case stx () - [(_ _TYPE ([slot slot-type] ...)) - (and (_-identifier? #'_TYPE stx) - (identifiers? #'(slot ...))) - (make-syntax #'_TYPE #f #'(slot ...) #'(slot-type ...))] - [(_ (_TYPE _SUPER) ([slot slot-type] ...)) - (and (_-identifier? #'_TYPE stx) (identifiers? #'(slot ...))) - (with-syntax ([super (datum->syntax #'_TYPE 'super #'_TYPE)]) - (make-syntax #'_TYPE #t #'(super slot ...) #'(_SUPER slot-type ...)))])) - -;; helper for the above: keep runtime information on structs -(define cstruct-info - (let ([table (make-weak-hasheq)]) - (lambda (cstruct msg/fail-thunk . args) - (cond [(eq? 'set! msg/fail-thunk) - (hash-set! table cstruct (make-ephemeron cstruct args))] - [(and cstruct ; might get a #f if there were no slots - (hash-ref table cstruct (lambda () #f))) - => (lambda (xs) - (let ([v (ephemeron-value xs)]) - (if v (apply values v) (msg/fail-thunk))))] - [else (msg/fail-thunk)])))) - -;; ---------------------------------------------------------------------------- -;; - -(define prim-synonyms - #hasheq((double* . double) - (fixint . long) - (ufixint . ulong) - (fixnum . long) - (ufixnum . ulong) - (path . bytes) - (symbol . bytes) - (scheme . pointer))) - -(define (ctype->layout c) - (let ([b (ctype-basetype c)]) - (cond - [(ctype? b) (ctype->layout b)] - [(list? b) (map ctype->layout b)] - [else (hash-ref prim-synonyms b b)]))) - -;; ---------------------------------------------------------------------------- -;; Misc utilities - -;; Used by set-ffi-obj! to get the actual value so it can be kept around -(define (get-lowlevel-object x type) - (let ([basetype (ctype-basetype type)]) - (if (ctype? basetype) - (let ([s->c (ctype-scheme->c type)]) - (get-lowlevel-object (if s->c (s->c x) x) basetype)) - (values x type)))) - -;; Converting Scheme lists to/from C vectors (going back requires a length) -(define* (list->cblock l type) - (if (null? l) - #f ; null => NULL - (let ([cblock (malloc (length l) type)]) - (let loop ([l l] [i 0]) - (unless (null? l) - (ptr-set! cblock type i (car l)) - (loop (cdr l) (add1 i)))) - cblock))) -(provide* (unsafe cblock->list)) -(define (cblock->list cblock type len) - (cond [(zero? len) '()] - [(cpointer? cblock) - (let loop ([i (sub1 len)] [r '()]) - (if (< i 0) - r - (loop (sub1 i) (cons (ptr-ref cblock type i) r))))] - [else (error 'cblock->list - "expecting a non-void pointer, got ~s" cblock)])) - -;; Converting Scheme vectors to/from C vectors -(define* (vector->cblock v type) - (let ([len (vector-length v)]) - (if (zero? len) - #f ; #() => NULL - (let ([cblock (malloc len type)]) - (let loop ([i 0]) - (when (< i len) - (ptr-set! cblock type i (vector-ref v i)) - (loop (add1 i)))) - cblock)))) -(provide* (unsafe cblock->vector)) -(define (cblock->vector cblock type len) - (cond [(zero? len) '#()] - [(cpointer? cblock) - (let ([v (make-vector len)]) - (let loop ([i (sub1 len)]) - (unless (< i 0) - (vector-set! v i (ptr-ref cblock type i)) - (loop (sub1 i)))) - v)] - [else (error 'cblock->vector - "expecting a non-void pointer, got ~s" cblock)])) - -;; Useful for automatic definitions -;; If a provided regexp begins with a "^" or ends with a "$", then -;; `regexp-replace' is used, otherwise use `regexp-replace*'. -(define* (regexp-replaces x rs) - (let loop ([str (if (bytes? x) (bytes->string/utf-8 x) (format "~a" x))] - [rs rs]) - (if (null? rs) - str - (loop ((if (regexp-match #rx"^\\^|\\$$" - (if (regexp? (caar rs)) - (object-name (caar rs)) (caar rs))) - regexp-replace regexp-replace*) - (caar rs) str (cadar rs)) (cdr rs))))) - -;; A facility for running finalizers using executors. #%foreign has a C-based -;; version that uses finalizers, but that leads to calling Scheme from the GC -;; which is not a good idea. -(define killer-executor (make-will-executor)) -(define killer-thread #f) - -(define* (register-finalizer obj finalizer) - (unless killer-thread - (set! killer-thread - (thread (lambda () - (let loop () (will-execute killer-executor) (loop)))))) - (will-register killer-executor obj finalizer)) - -(define-unsafer unsafe!) +(module foreign scheme/base + (require scheme/foreign) + (provide (all-from-out scheme/foreign))) diff --git a/collects/mzlib/pretty.ss b/collects/mzlib/pretty.ss index 7e38db918d..8c750b51d3 100644 --- a/collects/mzlib/pretty.ss +++ b/collects/mzlib/pretty.ss @@ -1050,6 +1050,11 @@ (pp-two-up expr extra pp-expr-list depth apair? acar acdr open close)) + (define (pp-module expr extra depth + apair? acar acdr open close) + (pp-two-up expr extra pp-expr depth + apair? acar acdr open close)) + (define (pp-make-object expr extra depth apair? acar acdr open close) (pp-one-up expr extra pp-expr-list depth @@ -1138,8 +1143,10 @@ ((do letrec-syntaxes+values) (and (no-sharing? expr 2 apair? acdr) pp-do)) - - ((send syntax-case instantiate module) + ((module) + (and (no-sharing? expr 2 apair? acdr) + pp-module)) + ((send syntax-case instantiate) (and (no-sharing? expr 2 apair? acdr) pp-syntax-case)) ((make-object) diff --git a/collects/net/cgi-unit.ss b/collects/net/cgi-unit.ss index ce92d4a38f..a42c3da5b3 100644 --- a/collects/net/cgi-unit.ss +++ b/collects/net/cgi-unit.ss @@ -96,32 +96,47 @@ ;; -- operates on the default input port; the second value indicates whether ;; reading stopped because an EOF was hit (as opposed to the delimiter being ;; seen); the delimiter is not part of the result -(define (read-until-char ip delimiter) +(define (read-until-char ip delimiter?) (let loop ([chars '()]) (let ([c (read-char ip)]) (cond [(eof-object? c) (values (reverse chars) #t)] - [(char=? c delimiter) (values (reverse chars) #f)] + [(delimiter? c) (values (reverse chars) #f)] [else (loop (cons c chars))])))) +;; delimiter->predicate : +;; symbol -> (char -> bool) +;; returns a predicates to pass to read-until-char +(define (delimiter->predicate delimiter) + (case delimiter + [(eq) (lambda (c) (char=? c #\=))] + [(amp) (lambda (c) (char=? c #\&))] + [(semi) (lambda (c) (char=? c #\;))] + [(amp-or-semi) (lambda (c) (or (char=? c #\&) (char=? c #\;)))])) + ;; read-name+value : iport -> (symbol + bool) x (string + bool) x bool ;; -- If the first value is false, so is the second, and the third is true, ;; indicating EOF was reached without any input seen. Otherwise, the first ;; and second values contain strings and the third is either true or false ;; depending on whether the EOF has been reached. The strings are processed ;; to remove the CGI spec "escape"s. This code is _slightly_ lax: it allows -;; an input to end in `&'. It's not clear this is legal by the CGI spec, +;; an input to end in (current-alist-separator-mode). +;; It's not clear this is legal by the CGI spec, ;; which suggests that the last value binding must end in an EOF. It doesn't ;; look like this matters. It would also introduce needless modality and ;; reduce flexibility. (define (read-name+value ip) - (let-values ([(name eof?) (read-until-char ip #\=)]) + (let-values ([(name eof?) (read-until-char ip (delimiter->predicate 'eq))]) (cond [(and eof? (null? name)) (values #f #f #t)] [eof? (generate-error-output (list "Server generated malformed input for POST method:" (string-append "No binding for `" (list->string name) "' field.")))] - [else (let-values ([(value eof?) (read-until-char ip #\&)]) + [else (let-values ([(value eof?) + (read-until-char + ip + (delimiter->predicate + (current-alist-separator-mode)))]) (values (string->symbol (query-chars->string name)) (query-chars->string value) eof?))]))) diff --git a/collects/net/head-unit.ss b/collects/net/head-unit.ss index 7b42b5a363..d5b82b9e5d 100644 --- a/collects/net/head-unit.ss +++ b/collects/net/head-unit.ss @@ -33,15 +33,15 @@ [(and (= (+ offset 2) len) (bytes=? CRLF/bytes (subbytes s offset len))) (void)] ; validated - [(= offset len) (error 'validate-header/bytes "missing ending CRLF")] + [(= offset len) (error 'validate-header "missing ending CRLF")] [(or (regexp-match re:field-start/bytes s offset) (regexp-match re:continue/bytes s offset)) (let ([m (regexp-match-positions #rx#"\r\n" s offset)]) (if m (loop (cdar m)) - (error 'validate-header/bytes "missing ending CRLF")))] - [else (error 'validate-header/bytes "ill-formed header at ~s" - (subbytes s offset (string-length s)))]))) + (error 'validate-header "missing ending CRLF")))] + [else (error 'validate-header "ill-formed header at ~s" + (subbytes s offset (bytes-length s)))]))) ;; otherwise it should be a string: (begin (let ([m (regexp-match #rx"[^\000-\377]" s)]) diff --git a/collects/net/scribblings/cgi.scrbl b/collects/net/scribblings/cgi.scrbl index abfb1795e2..e81f5ce91f 100644 --- a/collects/net/scribblings/cgi.scrbl +++ b/collects/net/scribblings/cgi.scrbl @@ -1,6 +1,7 @@ #lang scribble/doc @(require "common.ss" (for-label net/cgi + net/uri-codec net/cgi-unit net/cgi-sig)) @@ -41,7 +42,10 @@ Returns the bindings that corresponding to the options specified by the user. The @scheme[get-bindings/post] and @scheme[get-bindings/get] variants work only when POST and GET forms are used, respectively, while @scheme[get-bindings] determines the -kind of form that was used and invokes the appropriate function.} +kind of form that was used and invokes the appropriate function. + +These functions respect @scheme[current-alist-separator-mode]. +} @defproc[(extract-bindings [key? (or/c symbol? string?)] diff --git a/collects/parser-tools/lex.ss b/collects/parser-tools/lex.ss index 4aceb59429..7613ecc9c1 100644 --- a/collects/parser-tools/lex.ss +++ b/collects/parser-tools/lex.ss @@ -81,7 +81,8 @@ (((special) act) (not (ormap (lambda (x) - (module-or-top-identifier=? (syntax special) x)) + (and (identifier? #'special) + (module-or-top-identifier=? (syntax special) x))) ids))) (_ #t))) spec/re-act-lst)) diff --git a/collects/parser-tools/parser-tools.scrbl b/collects/parser-tools/parser-tools.scrbl index d10806ab5d..a49958ddf7 100644 --- a/collects/parser-tools/parser-tools.scrbl +++ b/collects/parser-tools/parser-tools.scrbl @@ -157,8 +157,8 @@ are a few examples, using @scheme[:] prefixed SRE syntax: action: @itemize{ - @item{@scheme[start-pos] --- a position struct for the first character matched.} - @item{@scheme[end-pos] --- a position struct for the character after the last character in the match.} + @item{@scheme[start-pos] --- a @scheme[position] struct for the first character matched.} + @item{@scheme[end-pos] --- a @scheme[position] struct for the character after the last character in the match.} @item{@scheme[lexeme] --- the matched string.} @item{@scheme[input-port] --- the input-port being processed (this is useful for matching input with multiple @@ -526,23 +526,27 @@ the right choice when using @scheme[lexer] in other situations. Each action is scheme code that has the same scope as its parser's definition, except that the variables @scheme[$1], ..., - @schemeidfont{$}@math{n} are bound, where @math{n} is the number + @schemeidfont{$}@math{i} are bound, where @math{i} is the number of @scheme[grammar-id]s in the corresponding production. Each - @schemeidfont{$}@math{i} is bound to the result of the action - for the @math{i}@superscript{th} grammar symbol on the right of + @schemeidfont{$}@math{k} is bound to the result of the action + for the @math{k}@superscript{th} grammar symbol on the right of the production, if that grammar symbol is a non-terminal, or the value stored in the token if the grammar symbol is a terminal. If the @scheme[src-pos] option is present in the parser, then variables @scheme[$1-start-pos], ..., - @schemeidfont{$}@math{n}@schemeidfont{-start-pos} and + @schemeidfont{$}@math{i}@schemeidfont{-start-pos} and @scheme[$1-end-pos], ..., - @schemeidfont{$}@math{n}@schemeidfont{-end-pos} and are also + @schemeidfont{$}@math{i}@schemeidfont{-end-pos} and are also available, and they refer to the position structures corresponding to the start and end of the corresponding @scheme[grammar-symbol]. Grammar symbols defined as empty-tokens - have no @schemeidfont{$}@math{i} associated, but do have + have no @schemeidfont{$}@math{k} associated, but do have + @schemeidfont{$}@math{k}@schemeidfont{-start-pos} and + @schemeidfont{$}@math{k}@schemeidfont{-end-pos}. + Also @schemeidfont{$n-start-pos} and @schemeidfont{$n-end-pos} + are bound to the largest start and end positions, (i.e., @schemeidfont{$}@math{i}@schemeidfont{-start-pos} and - @schemeidfont{$}@math{i}@schemeidfont{-end-pos}. + @schemeidfont{$}@math{i}@schemeidfont{-end-pos}). All of the productions for a given non-terminal must be grouped with it. That is, no @scheme[non-terminal-id] may appear twice diff --git a/collects/parser-tools/private-lex/actions.ss b/collects/parser-tools/private-lex/actions.ss index 10330a899d..6ec0c7f491 100644 --- a/collects/parser-tools/private-lex/actions.ss +++ b/collects/parser-tools/private-lex/actions.ss @@ -1,19 +1,16 @@ -(module actions mzscheme - (provide (all-defined)) - (require syntax/stx) - - ;; get-special-action: (syntax-object list) syntax-object syntax-object -> syntax-object - ;; Returns the first action from a rule of the form ((which-special) action) - (define (get-special-action rules which-special none) - (cond - ((null? rules) none) - (else - (syntax-case (car rules) () - (((special) act) - (module-or-top-identifier=? (syntax special) which-special) - (syntax act)) - (_ (get-special-action (cdr rules) which-special none)))))) - +#lang scheme/base - - ) +(provide (all-defined-out)) +(require syntax/stx) + +;; get-special-action: (syntax-object list) syntax-object syntax-object -> syntax-object +;; Returns the first action from a rule of the form ((which-special) action) +(define (get-special-action rules which-special none) + (cond + ((null? rules) none) + (else + (syntax-case (car rules) () + (((special) act) + (and (identifier? #'special) (module-or-top-identifier=? (syntax special) which-special)) + (syntax act)) + (_ (get-special-action (cdr rules) which-special none)))))) diff --git a/collects/parser-tools/private-yacc/input-file-parser.ss b/collects/parser-tools/private-yacc/input-file-parser.ss index c8508f6cdc..5c6771c94e 100644 --- a/collects/parser-tools/private-yacc/input-file-parser.ss +++ b/collects/parser-tools/private-yacc/input-file-parser.ss @@ -18,9 +18,10 @@ (define stx-for-original-property (read-syntax #f (open-input-string "original"))) - ;; get-args: ??? + ;; get-args: ??? -> (values (listof syntax) (or/c #f (cons integer? stx))) (define (get-args i rhs src-pos term-defs) - (let ((empty-table (make-hash-table))) + (let ((empty-table (make-hash-table)) + (biggest-pos #f)) (hash-table-put! empty-table 'error #t) (for-each (lambda (td) (let ((v (syntax-local-value td))) @@ -29,24 +30,31 @@ (hash-table-put! empty-table (syntax-object->datum s) #t)) (syntax->list (e-terminals-def-t v)))))) term-defs) - (let get-args ((i i) - (rhs rhs)) - (cond - ((null? rhs) null) - (else - (let ((b (car rhs)) - (name (if (hash-table-get empty-table (syntax-object->datum (car rhs)) (lambda () #f)) - (gensym) - (string->symbol (format "$~a" i))))) - (cond - (src-pos - `(,(datum->syntax-object b name b stx-for-original-property) - ,(datum->syntax-object b (string->symbol (format "$~a-start-pos" i)) b stx-for-original-property) - ,(datum->syntax-object b (string->symbol (format "$~a-end-pos" i)) b stx-for-original-property) - ,@(get-args (add1 i) (cdr rhs)))) - (else - `(,(datum->syntax-object b name b stx-for-original-property) - ,@(get-args (add1 i) (cdr rhs))))))))))) + (let ([args + (let get-args ((i i) + (rhs rhs)) + (cond + ((null? rhs) null) + (else + (let ((b (car rhs)) + (name (if (hash-table-get empty-table (syntax-object->datum (car rhs)) (lambda () #f)) + (gensym) + (string->symbol (format "$~a" i))))) + (cond + (src-pos + (let ([start-pos-id + (datum->syntax-object b (string->symbol (format "$~a-start-pos" i)) b stx-for-original-property)] + [end-pos-id + (datum->syntax-object b (string->symbol (format "$~a-end-pos" i)) b stx-for-original-property)]) + (set! biggest-pos (cons start-pos-id end-pos-id)) + `(,(datum->syntax-object b name b stx-for-original-property) + ,start-pos-id + ,end-pos-id + ,@(get-args (add1 i) (cdr rhs))))) + (else + `(,(datum->syntax-object b name b stx-for-original-property) + ,@(get-args (add1 i) (cdr rhs)))))))))]) + (values args biggest-pos)))) ;; Given the list of terminal symbols and the precedence/associativity definitions, ;; builds terminal structures (See grammar.ss) @@ -250,9 +258,18 @@ ;; parse-action: syntax-object * syntax-object -> syntax-object (parse-action (lambda (rhs act) - (quasisyntax/loc act - (lambda #,(get-args 1 (syntax->list rhs) src-pos term-defs) - #,act)))) + (let-values ([(args biggest) (get-args 1 (syntax->list rhs) src-pos term-defs)]) + (let ([act + (if biggest + (with-syntax ([$n-start-pos (datum->syntax-object (car biggest) '$n-start-pos)] + [$n-end-pos (datum->syntax-object (cdr biggest) '$n-end-pos)]) + #`(let ([$n-start-pos #,(car biggest)] + [$n-end-pos #,(cdr biggest)]) + #,act)) + act)]) + (quasisyntax/loc act + (lambda #,args + #,act)))))) ;; parse-prod+action: non-term * syntax-object -> production (parse-prod+action diff --git a/collects/parser-tools/private-yacc/table.ss b/collects/parser-tools/private-yacc/table.ss index 9493b65ba3..bd5107b9b1 100644 --- a/collects/parser-tools/private-yacc/table.ss +++ b/collects/parser-tools/private-yacc/table.ss @@ -1,4 +1,4 @@ -(module table mzscheme +#lang scheme/base ;; Routine to build the LALR table @@ -31,14 +31,14 @@ (list->vector (map (lambda (state-entry) - (let ((ht (make-hash-table 'equal))) + (let ((ht (make-hash))) (for-each (lambda (gs/actions) - (let ((group (hash-table-get ht (car gs/actions) (lambda () null)))) + (let ((group (hash-ref ht (car gs/actions) (lambda () null)))) (unless (member (cdr gs/actions) group) - (hash-table-put! ht (car gs/actions) (cons (cdr gs/actions) group))))) + (hash-set! ht (car gs/actions) (cons (cdr gs/actions) group))))) state-entry) - (hash-table-map ht cons))) + (hash-map ht cons))) (vector->list table)))) ;; table-map : (vectorof (listof (cons/c gram-sym? X))) (gram-sym? X -> Y) -> @@ -119,19 +119,23 @@ (print-entry sym (car act) port)) (else (fprintf port "begin conflict:~n") - (if (> (count reduce? act) 1) - (set! RR-conflicts (add1 RR-conflicts))) - (if (> (count shift? act) 0) - (set! SR-conflicts (add1 SR-conflicts))) + (when (> (count reduce? act) 1) + (set! RR-conflicts (add1 RR-conflicts))) + (when (> (count shift? act) 0) + (set! SR-conflicts (add1 SR-conflicts))) (map (lambda (x) (print-entry sym x port)) act) (fprintf port "end conflict~n"))))) (vector-ref grouped-table (kernel-index state))) (newline port))) (when (> SR-conflicts 0) - (fprintf port "~a shift/reduce conflicts~n" SR-conflicts)) + (fprintf port "~a shift/reduce conflict~a~n" + SR-conflicts + (if (= SR-conflicts 1) "" "s"))) (when (> RR-conflicts 0) - (fprintf port "~a reduce/reduce conflicts~n" RR-conflicts)))) + (fprintf port "~a reduce/reduce conflict~a~n" + RR-conflicts + (if (= RR-conflicts 1) "" "s"))))) ;; resolve-conflict : (listof action?) -> action? bool bool (define (resolve-conflict actions) @@ -176,12 +180,14 @@ (unless suppress (when (> SR-conflicts 0) (fprintf (current-error-port) - "~a shift/reduce conflicts~n" - SR-conflicts)) + "~a shift/reduce conflict~a~n" + SR-conflicts + (if (= SR-conflicts 1) "" "s"))) (when (> RR-conflicts 0) (fprintf (current-error-port) - "~a reduce/reduce conflicts~n" - RR-conflicts))) + "~a reduce/reduce conflict~a~n" + RR-conflicts + (if (= RR-conflicts 1) "" "s")))) table)) @@ -230,7 +236,7 @@ (end-terms (send g get-end-terms)) (table (make-parse-table (send a get-num-states))) (get-lookahead (compute-LA a g)) - (reduce-cache (make-hash-table 'equal))) + (reduce-cache (make-hash))) (for-each (lambda (trans-key/state) @@ -256,17 +262,17 @@ (bit-vector-for-each (lambda (term-index) (unless (start-item? item) - (let ((r (hash-table-get reduce-cache item-prod + (let ((r (hash-ref reduce-cache item-prod (lambda () (let ((r (make-reduce item-prod))) - (hash-table-put! reduce-cache item-prod r) + (hash-set! reduce-cache item-prod r) r))))) (table-add! table (kernel-index state) (vector-ref term-vector term-index) r)))) (get-lookahead state item-prod)))) - (append (hash-table-get (send a get-epsilon-trans) state (lambda () null)) + (append (hash-ref (send a get-epsilon-trans) state (lambda () null)) (filter (lambda (item) (not (move-dot-right item))) (kernel-items state)))))) @@ -277,13 +283,12 @@ (lambda (e) (fprintf (current-error-port) - "Cannot write debug output to file \"~a\".~n" - file)))] + "Cannot write debug output to file \"~a\": ~a\n" + file + (exn-message e))))] (call-with-output-file file (lambda (port) - (display-parser a grouped-table (send g get-prods) port))))) + (display-parser a grouped-table (send g get-prods) port)) + #:exists 'truncate))) (resolve-conflicts grouped-table suppress)))) - - ) - - + \ No newline at end of file diff --git a/collects/parser-tools/yacc.ss b/collects/parser-tools/yacc.ss index 0c16284c05..296e027aa6 100644 --- a/collects/parser-tools/yacc.ss +++ b/collects/parser-tools/yacc.ss @@ -1,9 +1,10 @@ -(module yacc mzscheme - - (require-for-syntax "private-yacc/parser-builder.ss" - "private-yacc/grammar.ss" - "private-yacc/yacc-helper.ss" - "private-yacc/parser-actions.ss") +#lang scheme/base + +(require (for-syntax scheme/base + "private-yacc/parser-builder.ss" + "private-yacc/grammar.ss" + "private-yacc/yacc-helper.ss" + "private-yacc/parser-actions.ss")) (require "private-lex/token.ss" "private-yacc/parser-actions.ss" mzlib/etc @@ -19,12 +20,12 @@ (list->vector (map (lambda (state-entry) - (let ((ht (make-hash-table))) + (let ((ht (make-hasheq))) (for-each (lambda (gs/action) - (hash-table-put! ht - (gram-sym-symbol (car gs/action)) - (action->runtime-action (cdr gs/action)))) + (hash-set! ht + (gram-sym-symbol (car gs/action)) + (action->runtime-action (cdr gs/action)))) state-entry) ht)) (vector->list table)))) @@ -177,13 +178,14 @@ yacc-output)))] (call-with-output-file yacc-output (lambda (port) - (display-yacc (syntax-object->datum grammar) + (display-yacc (syntax->datum grammar) tokens - (map syntax-object->datum start) + (map syntax->datum start) (if precs - (syntax-object->datum precs) + (syntax->datum precs) #f) - port))))) + port)) + #:exists 'truncate))) (with-syntax ((check-syntax-fix check-syntax-fix) (err error) (ends end) @@ -245,7 +247,7 @@ (define (extract-no-src-pos ip) (extract-helper ip #f #f)) - (define-struct stack-frame (state value start-pos end-pos) (make-inspector)) + (define-struct stack-frame (state value start-pos end-pos) #:inspector (make-inspector)) (define (make-empty-stack i) (list (make-stack-frame i #f #f #f))) @@ -304,17 +306,17 @@ (remove-states))))))))) (define (find-action stack tok val start-pos end-pos) - (unless (hash-table-get all-term-syms - tok - (lambda () #f)) + (unless (hash-ref all-term-syms + tok + #f) (if src-pos (err #f tok val start-pos end-pos) (err #f tok val)) (raise-read-error (format "parser: got token of unknown type ~a" tok) #f #f #f #f #f)) - (hash-table-get (vector-ref table (stack-frame-state (car stack))) - tok - (lambda () #f))) + (hash-ref (vector-ref table (stack-frame-state (car stack))) + tok + #f)) (define (make-parser start-number) (lambda (get-token) @@ -341,7 +343,7 @@ src-pos))) (let ((goto (runtime-goto-state - (hash-table-get + (hash-ref (vector-ref table (stack-frame-state (car new-stack))) (runtime-reduce-lhs action))))) (parsing-loop @@ -378,4 +380,3 @@ (cond ((null? l) null) (else (cons (make-parser i) (loop (cdr l) (add1 i)))))))))) - ) diff --git a/collects/r5rs/main.ss b/collects/r5rs/main.ss index a39d84d29d..6e48ff2b52 100644 --- a/collects/r5rs/main.ss +++ b/collects/r5rs/main.ss @@ -1,10 +1,14 @@ (module main scheme/base (require scheme/mpair - (for-syntax scheme/base syntax/kerncase) + (for-syntax scheme/base syntax/kerncase + "private/r5rs-trans.ss") (only-in mzscheme transcript-on transcript-off)) - (provide (for-syntax syntax-rules ...) + (provide (for-syntax syntax-rules ... + (rename-out [syntax-rules-only #%top] + [syntax-rules-only #%app] + [syntax-rules-only #%datum])) (rename-out [mcons cons] [mcar car] diff --git a/collects/r5rs/private/r5rs-trans.ss b/collects/r5rs/private/r5rs-trans.ss new file mode 100644 index 0000000000..62fa57ccef --- /dev/null +++ b/collects/r5rs/private/r5rs-trans.ss @@ -0,0 +1,11 @@ +#lang scheme/base +(require (for-syntax scheme/base)) +(provide syntax-rules-only) + +(define-syntax (syntax-rules-only stx) + (syntax-case stx () + [(_ . form) + (raise-syntax-error + 'macro-transformer + "only a `syntax-rules' form is allowed" + #'form)])) diff --git a/collects/r5rs/r5rs.scrbl b/collects/r5rs/r5rs.scrbl index 6da1ff522a..ffcb6a8629 100644 --- a/collects/r5rs/r5rs.scrbl +++ b/collects/r5rs/r5rs.scrbl @@ -1,6 +1,7 @@ #lang scribble/doc @(require scribble/manual - (for-label r5rs + (for-label (only-meta-in 0 r5rs) + (only-in r5rs syntax-rules ...) (only-in mzscheme #%plain-module-begin) (only-in scheme/mpair mmap) (only-in scheme/contract one-of/c) diff --git a/collects/redex/private/matcher.ss b/collects/redex/private/matcher.ss index 8ac741baf8..0b4edac046 100644 --- a/collects/redex/private/matcher.ss +++ b/collects/redex/private/matcher.ss @@ -18,8 +18,6 @@ before the pattern compiler is invoked. (define-struct compiled-pattern (cp)) -(define count 0) - (define caching-enabled? (make-parameter #t)) ;; lang = (listof nt) diff --git a/collects/redex/private/rg-test.ss b/collects/redex/private/rg-test.ss index fafdb8079d..2a0e6974fd 100644 --- a/collects/redex/private/rg-test.ss +++ b/collects/redex/private/rg-test.ss @@ -530,6 +530,14 @@ (decisions #:nt (patterns fourth first first second first first first) #:var (list (λ _ 'x) (λ _ 'y)))) (term (λ (x) (hole y))))) +(let () + (define-language L + (a ((a ...) ...))) + (test (generate-term/decisions + L (cross a) 3 0 + (decisions #:nt (patterns second first) + #:seq (list (λ _ 0) (λ _ 0) (λ _ 0) (λ _ 0)))) + (term ((hole))))) ;; generation failures increase size and attempt (let () diff --git a/collects/redex/private/rg.ss b/collects/redex/private/rg.ss index 50732ad1bd..65b9b00463 100644 --- a/collects/redex/private/rg.ss +++ b/collects/redex/private/rg.ss @@ -620,7 +620,7 @@ To do a better job of not generating programs with free variables, (struct-copy compiled-lang lang [lang (map (parse-nt 'grammar) (compiled-lang-lang lang))] - [cclang (map (parse-nt 'top-level) (compiled-lang-cclang lang))])) + [cclang (map (parse-nt 'cross) (compiled-lang-cclang lang))])) ;; unparse-pattern: parsed-pattern -> pattern (define unparse-pattern diff --git a/collects/scheme/foreign.ss b/collects/scheme/foreign.ss index 1a2b729546..122b11c8ba 100644 --- a/collects/scheme/foreign.ss +++ b/collects/scheme/foreign.ss @@ -1,4 +1,1626 @@ +#lang scheme/base -(module foreign scheme/base - (require mzlib/foreign) - (provide (all-from-out mzlib/foreign))) +;; Foreign Scheme interface +(require '#%foreign setup/dirs + (for-syntax scheme/base scheme/list syntax/stx)) + +;; This module is full of unsafe bindings that are not provided to requiring +;; modules. Instead, an `unsafe!' binding is provided that makes these unsafe +;; bindings available. The following two syntaxes do that: `provide*' is like +;; `provide', but using `(unsafe id)' registers an unsafe binding. Then, +;; `define-unsafer' should be used with a binding that will expose the unsafe +;; bindings. This might move elsewhere at some point if it turns out to be +;; useful in other contexts. +(provide provide* define-unsafer) +(define-syntaxes (provide* define-unsafer) + (let ((unsafe-bindings '())) + (values + (lambda (stx) + (syntax-case stx () + [(_ p ...) + (let loop ([provides '()] + [unsafes '()] + [ps (syntax->list #'(p ...))]) + (if (null? ps) + (begin (set! unsafe-bindings + (append unsafe-bindings (reverse unsafes))) + (with-syntax ([(p ...) provides]) #'(provide p ...))) + (syntax-case (car ps) (unsafe) + [(unsafe u) + (syntax-case #'u (rename-out) + [(rename-out [from to]) + (loop provides (cons (cons #'from #'to) unsafes) (cdr ps))] + [id (identifier? #'id) + (loop provides (cons (cons #'id #'id) unsafes) (cdr ps))] + [_ + (raise-syntax-error 'provide* "bad unsafe usage" + (car ps) stx)])] + [_ (loop (cons (car ps) provides) unsafes (cdr ps))])))])) + (lambda (stx) + (syntax-case stx () + [(_ unsafe) + (with-syntax ([(from ...) (map car unsafe-bindings)] + [(to ...) (map cdr unsafe-bindings)] + [(id ...) (generate-temporaries unsafe-bindings)]) + (set! unsafe-bindings '()) + #'(begin + (provide (protect-out unsafe)) + (define-syntax (unsafe stx) + (syntax-case stx () + [(_) (with-syntax ([(id ...) (list (datum->syntax + stx 'to stx) + ...)]) + #'(begin (define-syntax id + (make-rename-transformer (syntax-property + (syntax-property + #'from + 'not-provide-all-defined + #t) + 'nominal-id + 'to))) + ...))]))))]))))) + +(provide* ctype-sizeof ctype-alignof compiler-sizeof + (unsafe malloc) (unsafe free) (unsafe end-stubborn-change) + cpointer? ptr-equal? ptr-add (unsafe ptr-ref) (unsafe ptr-set!) + ptr-offset ptr-add! offset-ptr? set-ptr-offset! + ctype? make-ctype make-cstruct-type (unsafe make-sized-byte-string) ctype->layout + _void _int8 _uint8 _int16 _uint16 _int32 _uint32 _int64 _uint64 + _fixint _ufixint _fixnum _ufixnum + _float _double _double* + _bool _pointer _scheme _fpointer function-ptr + (unsafe memcpy) (unsafe memmove) (unsafe memset) + (unsafe malloc-immobile-cell) (unsafe free-immobile-cell)) + +(define-syntax define* + (syntax-rules () + [(_ (name . args) body ...) + (begin (provide name) (define (name . args) body ...))] + [(_ name expr) + (begin (provide name) (define name expr))])) + +;; ---------------------------------------------------------------------------- +;; C integer types + +(define* _sint8 _int8) +(define* _sint16 _int16) +(define* _sint32 _int32) +(define* _sint64 _int64) + +;; _byte etc is a convenient name for _uint8 & _sint8 +;; (_byte is unsigned) +(define* _byte _uint8) +(define* _ubyte _uint8) +(define* _sbyte _int8) + +;; _word etc is a convenient name for _uint16 & _sint16 +;; (_word is unsigned) +(define* _word _uint16) +(define* _uword _uint16) +(define* _sword _int16) + +;; _short etc is a convenient name for whatever is the compiler's `short' +;; (_short is signed) +(provide _short _ushort _sshort) +(define-values (_short _ushort _sshort) + (case (compiler-sizeof 'short) + [(2) (values _int16 _uint16 _int16)] + [(4) (values _int32 _uint32 _int32)] + [else (error 'foreign "internal error: bad compiler size for `short'")])) + +;; _int etc is a convenient name for whatever is the compiler's `int' +;; (_int is signed) +(provide _int _uint _sint) +(define-values (_int _uint _sint) + (case (compiler-sizeof 'int) + [(2) (values _int16 _uint16 _int16)] + [(4) (values _int32 _uint32 _int32)] + [(8) (values _int64 _uint64 _int64)] + [else (error 'foreign "internal error: bad compiler size for `int'")])) + +;; _long etc is a convenient name for whatever is the compiler's `long' +;; (_long is signed) +(provide _long _ulong _slong) +(define-values (_long _ulong _slong) + (case (compiler-sizeof 'long) + [(4) (values _int32 _uint32 _int32)] + [(8) (values _int64 _uint64 _int64)] + [else (error 'foreign "internal error: bad compiler size for `long'")])) + +;; _llong etc is a convenient name for whatever is the compiler's `long long' +;; (_llong is signed) +(provide _llong _ullong _sllong) +(define-values (_llong _ullong _sllong) + (case (compiler-sizeof '(long long)) + [(4) (values _int32 _uint32 _int32)] + [(8) (values _int64 _uint64 _int64)] + [else (error 'foreign "internal error: bad compiler size for `llong'")])) + +;; ---------------------------------------------------------------------------- +;; Getting and setting library objects + +(define lib-suffix (bytes->string/latin-1 (subbytes (system-type 'so-suffix) 1))) +(define lib-suffix-re (regexp (string-append "\\." lib-suffix "$"))) +(define suffix-before-version? (not (equal? lib-suffix "dylib"))) + +(provide* (unsafe (rename-out [get-ffi-lib ffi-lib])) + ffi-lib? ffi-lib-name) +(define get-ffi-lib + (case-lambda + [(name) (get-ffi-lib name "")] + [(name version/s) + (cond + [(not name) (ffi-lib name)] ; #f => NULL => open this executable + [(not (or (string? name) (path? name))) + (raise-type-error 'ffi-lib "library-name" name)] + [else + ;; A possible way that this might be misleading: say that there is a + ;; "foo.so" file in the current directory, which refers to some + ;; undefined symbol, trying to use this function with "foo.so" will try + ;; a dlopen with "foo.so" which isn't found, then it tries a dlopen with + ;; "//foo.so" which fails because of the undefined symbol, and + ;; since all fails, it will use (ffi-lib "foo.so") to raise the original + ;; file-not-found error. This is because the dlopen doesn't provide a + ;; way to distinguish different errors (only dlerror, but that's + ;; unreliable). + (let* ([versions (if (list? version/s) version/s (list version/s))] + [versions (map (lambda (v) + (if (or (not v) (zero? (string-length v))) + "" (string-append "." v))) + versions)] + [fullpath (lambda (p) (path->complete-path (cleanse-path p)))] + [absolute? (absolute-path? name)] + [name0 (path->string (cleanse-path name))] ; orig name + [names (map (if (regexp-match lib-suffix-re name0) ; name+suffix + (lambda (v) (string-append name0 v)) + (lambda (v) + (if suffix-before-version? + (string-append name0 "." lib-suffix v) + (string-append name0 v "." lib-suffix)))) + versions)] + [ffi-lib* (lambda (name) (ffi-lib name #t))]) + (or ;; try to look in our library paths first + (and (not absolute?) + (ormap (lambda (dir) + ;; try good names first, then original + (or (ormap (lambda (name) + (ffi-lib* (build-path dir name))) + names) + (ffi-lib* (build-path dir name0)))) + (get-lib-search-dirs))) + ;; try a system search + (ormap ffi-lib* names) ; try good names first + (ffi-lib* name0) ; try original + (ormap (lambda (name) ; try relative paths + (and (file-exists? name) (ffi-lib* (fullpath name)))) + names) + (and (file-exists? name0) ; relative with original + (ffi-lib* (fullpath name0))) + ;; give up: call ffi-lib so it will raise an error + (ffi-lib (car names))))])])) + +(define (get-ffi-lib-internal x) + (if (ffi-lib? x) x (get-ffi-lib x))) + +;; These internal functions provide the functionality to be used by +;; get-ffi-obj, set-ffi-obj! and define-c below +(define (ffi-get ffi-obj type) + (ptr-ref ffi-obj type)) +(define (ffi-set! ffi-obj type new) + (let-values ([(new type) (get-lowlevel-object new type)]) + (hash-set! ffi-objects-ref-table ffi-obj new) + (ptr-set! ffi-obj type new))) + +;; This is better handled with `make-c-parameter' +(provide* (unsafe ffi-obj-ref)) +(define ffi-obj-ref + (case-lambda + [(name lib) (ffi-obj-ref name lib #f)] + [(name lib failure) + (let ([name (get-ffi-obj-name 'ffi-obj-ref name)] + [lib (get-ffi-lib-internal lib)]) + (with-handlers ([exn:fail:filesystem? + (lambda (e) (if failure (failure) (raise e)))]) + (ffi-obj name lib)))])) + +;; get-ffi-obj is implemented as a syntax only to be able to propagate the +;; foreign name into the type syntax, which allows generated wrappers to have a +;; proper name. +(provide* (unsafe get-ffi-obj)) +(define get-ffi-obj* + (case-lambda + [(name lib type) (get-ffi-obj* name lib type #f)] + [(name lib type failure) + (let ([name (get-ffi-obj-name 'get-ffi-obj name)] + [lib (get-ffi-lib-internal lib)]) + (let-values ([(obj error?) + (with-handlers + ([exn:fail:filesystem? + (lambda (e) + (if failure (values (failure) #t) (raise e)))]) + (values (ffi-obj name lib) #f))]) + (if error? obj (ffi-get obj type))))])) +(define-syntax (get-ffi-obj stx) + (syntax-case stx () + [(_ name lib type) + #`(get-ffi-obj* name lib #,(syntax-property #`type 'ffi-name #'name))] + [(_ name lib type failure) + #`(get-ffi-obj* name lib #,(syntax-property #`type 'ffi-name #'name) + failure)] + [x (identifier? #'x) #'get-ffi-obj*])) + +;; It is important to use the set-ffi-obj! wrapper because it takes care of +;; keeping a handle on the object -- otherwise, setting a callback hook will +;; crash when the Scheme function is gone. +(provide* (unsafe set-ffi-obj!)) +(define (set-ffi-obj! name lib type new) + (ffi-set! (ffi-obj (get-ffi-obj-name 'set-ffi-obj! name) + (get-ffi-lib-internal lib)) + type new)) + +;; Combining the above two in a `define-c' special form which makes a Scheme +;; `binding', first a `parameter'-like constructor: +(provide* (unsafe make-c-parameter)) +(define (make-c-parameter name lib type) + (let ([obj (ffi-obj (get-ffi-obj-name 'make-c-parameter name) + (get-ffi-lib-internal lib))]) + (case-lambda [() (ffi-get obj type)] + [(new) (ffi-set! obj type new)]))) +;; Then the fake binding syntax, uses the defined identifier to name the +;; object: +(provide* (unsafe define-c)) +(define-syntax (define-c stx) + (syntax-case stx () + [(_ var-name lib-name type-expr) + (with-syntax ([(p) (generate-temporaries (list #'var-name))]) + (namespace-syntax-introduce + #'(begin (define p (make-c-parameter 'var-name lib-name type-expr)) + (define-syntax var-name + (syntax-id-rules (set!) + [(set! var val) (p val)] + [(var . xs) ((p) . xs)] + [var (p)])))))])) + +;; Used to convert strings and symbols to a byte-string that names an object +(define (get-ffi-obj-name who objname) + (cond [(bytes? objname) objname] + [(symbol? objname) (get-ffi-obj-name who (symbol->string objname))] + [(string? objname) (string->bytes/utf-8 objname)] + [else (raise-type-error who "object-name" objname)])) + +;; This table keeps references to values that are set in foreign libraries, to +;; avoid them being GCed. See set-ffi-obj! above. +(define ffi-objects-ref-table (make-hasheq)) + +;; ---------------------------------------------------------------------------- +;; Compile-time support for fun-expanders + +(begin-for-syntax + + ;; The `_fun' macro tears its input apart and reassemble it using pieces from + ;; custom function types (macros). This whole deal needs some work to make + ;; it play nicely with code certificates, so Matthew wrote the following + ;; code. The idea is to create a define-fun-syntax which makes the new + ;; syntax transformer be an object that carries extra information, later used + ;; by `expand-fun-syntax/fun'. + + (define fun-cert-key (gensym)) + + ;; bug in begin-for-syntax (PR7104), see below + (define foo!!! (make-parameter #f)) + (define (expand-fun-syntax/normal fun-stx stx) + ((foo!!!) fun-stx stx)) + + (define-values (make-fun-syntax fun-syntax? + fun-syntax-proc fun-syntax-certifier fun-syntax-name) + (let-values ([(desc make pred? get set!) + (make-struct-type + 'fun-syntax #f 3 0 #f '() (current-inspector) + expand-fun-syntax/normal)]) + (values make pred? + (make-struct-field-accessor get 0 'proc) + (make-struct-field-accessor get 1 'certifier) + (make-struct-field-accessor get 2 'name)))) + + ;; This is used to expand a fun-syntax in a _fun type context. + (define (expand-fun-syntax/fun stx) + (let loop ([stx stx]) + (define (do-expand id id?) ; id? == are we expanding an identifier? + (define v (syntax-local-value id (lambda () #f))) + (define set!-trans? (set!-transformer? v)) + (define proc (if set!-trans? (set!-transformer-procedure v) v)) + (if (and (fun-syntax? proc) (or (not id?) set!-trans?)) + ;; Do essentially the same thing that `local-expand' does. + ;; First, create an "introducer" to mark introduced identifiers: + (let* ([introduce (make-syntax-introducer)] + [expanded + ;; Re-introduce mark related to expansion of `_fun': + (syntax-local-introduce + ;; Re-add mark specific to this expansion, cancelling + ;; some marks applied before expanding (leaving only + ;; introuced syntax marked) + (introduce + ;; Actually expand: + ((fun-syntax-proc proc) + ;; Add mark specific to this expansion: + (introduce + ;; Remove mark related to expansion of `_fun': + (syntax-local-introduce stx)))))]) + ;; Certify based on definition of expander, then loop + ;; to continue expanding: + (loop ((fun-syntax-certifier proc) + expanded fun-cert-key introduce))) + stx)) + (syntax-case stx () + [(id . rest) (identifier? #'id) (do-expand #'id #f)] + [id (identifier? #'id) (do-expand #'id #t)] + [_else stx]))) + + ;; Use module-or-top-identifier=? because we use keywords like `=' and want + ;; to make it possible to play with it at the toplevel. + (define id=? module-or-top-identifier=?) + + (define (split-by key args) + (let loop ([args args] [r (list '())]) + (cond [(null? args) (reverse (map reverse r))] + [(eq? key (car args)) (loop (cdr args) (cons '() r))] + [else (loop (cdr args) + (cons (cons (car args) (car r)) (cdr r)))]))) + + (define (add-renamer body from to) + (with-syntax ([body body] [from from] [to to]) + #'(let-syntax ([to (syntax-id-rules () + [(_?_ . _rest_) (from . _rest_)] [_?_ from])]) + body))) + + (define (custom-type->keys type err) + (define stops (map (lambda (s) (datum->syntax type s #f)) + '(#%app #%top #%datum))) + ;; Expand `type' using expand-fun-syntax/fun + (define orig (expand-fun-syntax/fun type)) + (define (with-arg x) + (syntax-case* x (=>) id=? + [(id => body) (identifier? #'id) + ;; Extract #'body from its context, use a key it needs certification: + (list (syntax-recertify #'id orig #f fun-cert-key) + (syntax-recertify #'body orig #f fun-cert-key))] + [_else x])) + (define (cert-id id) + (syntax-recertify id orig #f fun-cert-key)) + (let ([keys '()]) + (define (setkey! key val . id?) + (cond + [(assq key keys) + (err "bad expansion of custom type (two `~a:'s)" key type)] + [(and (pair? id?) (car id?) (not (identifier? val))) + (err "bad expansion of custom type (`~a:' expects an identifier)" + key type)] + [else (set! keys (cons (cons key val) keys))])) + (let loop ([t orig]) + (define (next rest . args) (apply setkey! args) (loop rest)) + (syntax-case* t (type: expr: bind: 1st-arg: prev-arg: pre: post:) id=? + [(type: t x ...) (next #'(x ...) 'type #'t)] + [(expr: e x ...) (next #'(x ...) 'expr #'e)] + [(bind: id x ...) (next #'(x ...) 'bind (cert-id #'id) #t)] + [(1st-arg: id x ...) (next #'(x ...) '1st (cert-id #'id) #t)] + [(prev-arg: id x ...) (next #'(x ...) 'prev (cert-id #'id) #t)] + ;; in the following two cases pass along orig for recertifying + [(pre: p x ...) (next #'(x ...) 'pre (with-arg #'p))] + [(post: p x ...) (next #'(x ...) 'post (with-arg #'p))] + [() (and (pair? keys) keys)] + [_else #f])))) + + ;; This is used for a normal expansion of fun-syntax, when not in a _fun type + ;; context. + ;; bug in begin-for-syntax (PR7104), see above + ;; should be (define (expand-fun-syntax/normal fun-stx stx) ...) + (foo!!! (lambda (fun-stx stx) + (define (err msg . sub) + (apply raise-syntax-error (fun-syntax-name fun-stx) msg stx sub)) + (let ([keys (custom-type->keys stx err)]) + (define (getkey key) (cond [(assq key keys) => cdr] [else #f])) + (define (notkey key) + (when (getkey key) + (err (format "this type must be used in a _fun expression (uses ~s)" + key)))) + (if keys + (let ([type (getkey 'type)] [pre (getkey 'pre)] [post (getkey 'post)]) + (unless type + (err "this type must be used in a _fun expression (#f type)")) + (for-each notkey '(expr bind 1st prev)) + (if (or pre post) + ;; a type with pre/post blocks + (let ([make-> (lambda (x what) + (cond [(not x) #'#f] + [(and (list? x) (= 2 (length x)) + (identifier? (car x))) + #`(lambda (#,(car x)) #,(cadr x))] + [else #`(lambda (_) + (error '#,(fun-syntax-name fun-stx) + "cannot be used to ~a" + #,what))]))]) + (with-syntax ([type type] + [scheme->c (make-> pre "send values to C")] + [c->scheme (make-> post "get values from C")]) + #'(make-ctype type scheme->c c->scheme))) + ;; simple type + type)) + ;; no keys => normal expansion + ((fun-syntax-proc fun-stx) stx)))))) + +;; Use define-fun-syntax instead of define-syntax for forms that +;; are to be expanded by `_fun': +(provide define-fun-syntax) +(define-syntax define-fun-syntax + (syntax-rules () + [(_ id trans) + (define-syntax id + (let* ([xformer trans] + [set!-trans? (set!-transformer? xformer)]) + (unless (or (and (procedure? xformer) + (procedure-arity-includes? xformer 1)) + set!-trans?) + (raise-type-error 'define-fun-syntax + "procedure (arity 1) or set!-transformer" + xformer)) + (let ([f (make-fun-syntax (if set!-trans? + (set!-transformer-procedure xformer) + xformer) + ;; Capture definition-time certificates: + (syntax-local-certifier) + 'id)]) + (if set!-trans? (make-set!-transformer f) f))))])) + +;; ---------------------------------------------------------------------------- +;; Function type + +;; Creates a simple function type that can be used for callouts and callbacks, +;; optionally applying a wrapper function to modify the result primitive +;; (callouts) or the input procedure (callbacks). +(define* (_cprocedure itypes otype + #:abi [abi #f] + #:wrapper [wrapper #f] + #:keep [keep #f] + #:atomic? [atomic? #f]) + (_cprocedure* itypes otype abi wrapper keep atomic?)) + +;; for internal use +(define held-callbacks (make-weak-hasheq)) +(define (_cprocedure* itypes otype abi wrapper keep atomic?) + (define-syntax-rule (make-it wrap) + (make-ctype _fpointer + (lambda (x) + (and x + (let ([cb (ffi-callback (wrap x) itypes otype abi atomic?)]) + (cond [(eq? keep #t) (hash-set! held-callbacks x cb)] + [(box? keep) + (let ([x (unbox keep)]) + (set-box! keep + (if (or (null? x) (pair? x)) (cons cb x) cb)))] + [(procedure? keep) (keep cb)]) + cb))) + (lambda (x) (and x (wrap (ffi-call x itypes otype abi)))))) + (if wrapper (make-it wrapper) (make-it begin))) + +;; Syntax for the special _fun type: +;; (_fun [{(name ... [. name]) | name} [-> expr] ::] +;; {type | (name : type [= expr]) | ([name :] type = expr)} ... +;; -> {type | (name : type)} +;; [-> expr]) +;; Usage: +;; `{(name ...) | ...} ::' specify explicit wrapper function formal arguments +;; `-> expr' can be used instead of the last expr +;; `type' input type (implies input, but see type macros next) +;; `(name : type = expr)' specify name and type, `= expr' means computed input +;; `-> type' output type (possibly with name) +;; `-> expr' specify different output, can use previous names +;; Also, see below for custom function types. + +(provide ->) ; to signal better errors when trying to use this with contracts +(define-syntax -> + (syntax-id-rules () + [_ (raise-syntax-error '-> "should be used only in a _fun context")])) + +(provide _fun) +(define-syntax (_fun stx) + (define (err msg . sub) (apply raise-syntax-error '_fun msg stx sub)) + (define xs #f) + (define abi #f) + (define keep #f) + (define atomic? #f) + (define inputs #f) + (define output #f) + (define bind '()) + (define pre '()) + (define post '()) + (define input-names #f) + (define output-type #f) + (define output-expr #f) + (define 1st-arg #f) + (define prev-arg #f) + (define (bind! x) (set! bind (append bind (list x)))) + (define (pre! x) (set! pre (append pre (list x)))) + (define (post! x) (set! post (append post (list x)))) + (define ((t-n-e clause) type name expr) + (let ([keys (custom-type->keys type err)]) + (define (getkey key) (cond [(assq key keys) => cdr] [else #f])) + (define (arg x . no-expr?) + (define use-expr? + (and (list? x) (= 2 (length x)) (identifier? (car x)))) + ;; when the current expr is not used with a (x => ...) form, + ;; either check that no expression is given or just make it + ;; disappear from the inputs. + (unless use-expr? + (if (and (pair? no-expr?) (car no-expr?) expr) + (err "got an expression for a custom type that do not use it" + clause) + (set! expr (void)))) + (set! x (if use-expr? (add-renamer (cadr x) name (car x)) x)) + (cond [(getkey '1st) => + (lambda (v) + (if 1st-arg + (set! x (add-renamer x 1st-arg v)) + (err "got a custom type that wants 1st arg too early" + clause)))]) + (cond [(getkey 'prev) => + (lambda (v) + (if prev-arg + (set! x (add-renamer x prev-arg v)) + (err "got a custom type that wants prev arg too early" + clause)))]) + x) + (when keys + (set! type (getkey 'type)) + (cond [(and (not expr) (getkey 'expr)) => (lambda (x) (set! expr x))]) + (cond [(getkey 'bind) => (lambda (x) (bind! #`[#,x #,name]))]) + (cond [(getkey 'pre) => (lambda (x) (pre! #`[#,name #,(arg x #t)]))]) + (cond [(getkey 'post) => (lambda (x) (post! #`[#,name #,(arg x)]))])) + ;; turn a #f syntax to #f + (set! type (and type (syntax-case type () [#f #f] [_ type]))) + (when type ; remember these for later usages + (unless 1st-arg (set! 1st-arg name)) + (set! prev-arg name)) + (list type name expr))) + (define (do-fun) + ;; parse keywords + (let loop () + (let ([k (and (pair? xs) (pair? (cdr xs)) (syntax-e (car xs)))]) + (define-syntax-rule (kwds [key var] ...) + (case k + [(key) (if var + (err (format "got a second ~s keyword") 'key (car xs)) + (begin (set! var (cadr xs)) (set! xs (cddr xs)) (loop)))] + ... + [else (err "unknown keyword" (car xs))])) + (when (keyword? k) (kwds [#:abi abi] [#:keep keep] [#:atomic? atomic?])))) + (unless abi (set! abi #'#f)) + (unless keep (set! keep #'#t)) + (unless atomic? (set! atomic? #'#f)) + ;; parse known punctuation + (set! xs (map (lambda (x) + (syntax-case* x (-> ::) id=? [:: '::] [-> '->] [_ x])) + xs)) + ;; parse "::" + (let ([s (split-by ':: xs)]) + (case (length s) + [(0) (err "something bad happened (::)")] + [(1) (void)] + [(2) (if (and (= 1 (length (car s))) (not (eq? '-> (caar s)))) + (begin (set! xs (cadr s)) (set! input-names (caar s))) + (err "bad wrapper formals"))] + [else (err "saw two or more instances of `::'")])) + ;; parse "->" + (let ([s (split-by '-> xs)]) + (case (length s) + [(0) (err "something bad happened (->)")] + [(1) (err "missing output type")] + [(2 3) (set! inputs (car s)) + (case (length (cadr s)) + [(1) (set! output-type (caadr s))] + [(0) (err "missing output type after `->'")] + [else (err "extraneous output type" (cadadr s))]) + (unless (null? (cddr s)) + (case (length (caddr s)) + [(1) (set! output-expr (caaddr s))] + [(0) (err "missing output expression after `->'")] + [else (err "extraneous output expression" + (cadr (caddr s)))]))] + [else (err "saw three or more instances of `->'")])) + (set! inputs + (map (lambda (sub temp) + (let ([t-n-e (t-n-e sub)]) + (syntax-case* sub (: =) id=? + [(name : type) (t-n-e #'type #'name #f)] + [(type = expr) (t-n-e #'type temp #'expr)] + [(name : type = expr) (t-n-e #'type #'name #'expr)] + [type (t-n-e #'type temp #f)]))) + inputs + (generate-temporaries (map (lambda (x) 'tmp) inputs)))) + ;; when processing the output type, only the post code matters + (set! pre! (lambda (x) #f)) + (set! output + (let ([temp (car (generate-temporaries #'(ret)))] + [t-n-e (t-n-e output-type)]) + (syntax-case* output-type (: =) id=? + [(name : type) (t-n-e #'type #'name output-expr)] + [(type = expr) (if output-expr + (err "extraneous output expression" #'expr) + (t-n-e #'type temp #'expr))] + [(name : type = expr) + (if output-expr + (err "extraneous output expression" #'expr) + (t-n-e #'type #'name #'expr))] + [type (t-n-e #'type temp output-expr)]))) + (if (or (caddr output) input-names (ormap caddr inputs) + (ormap (lambda (x) (not (car x))) inputs) + (pair? bind) (pair? pre) (pair? post)) + (let* ([input-names (or input-names + (filter-map (lambda (i) + (and (not (caddr i)) (cadr i))) + inputs))] + [output-expr (let ([o (caddr output)]) + (or (and (not (void? o)) o) + (cadr output)))] + [args (filter-map (lambda (i) + (and (caddr i) + (not (void? (caddr i))) + #`[#,(cadr i) #,(caddr i)])) + inputs)] + [ffi-args (filter-map (lambda (x) (and (car x) (cadr x))) inputs)] + ;; the actual wrapper body + [body (quasisyntax/loc stx + (lambda #,input-names + (let* (#,@args + #,@bind + #,@pre + [#,(cadr output) (ffi #,@ffi-args)] + #,@post) + #,output-expr)))] + ;; if there is a string 'ffi-name property, use it as a name + [body (let ([n (cond [(syntax-property stx 'ffi-name) + => syntax->datum] + [else #f])]) + (if (string? n) + (syntax-property + body 'inferred-name + (string->symbol (string-append "ffi-wrapper:" n))) + body))]) + #`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output) + #,abi (lambda (ffi) #,body) #,keep #,atomic?)) + #`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output) + #,abi #f #,keep #,atomic?))) + (syntax-case stx () + [(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))])) + +(define (function-ptr p fun-ctype) + (if (or (cpointer? p) (procedure? p)) + (if (eq? (ctype->layout fun-ctype) 'fpointer) + (if (procedure? p) + ((ctype-scheme->c fun-ctype) p) + ((ctype-c->scheme fun-ctype) p)) + (raise-type-error 'function-ptr "function ctype" fun-ctype)) + (raise-type-error 'function-ptr "cpointer" p))) + +;; ---------------------------------------------------------------------------- +;; String types + +;; The internal _string type uses the native ucs-4 encoding, also providing a +;; utf-16 type +(provide _string/ucs-4 _string/utf-16) + +;; 8-bit string encodings, #f is NULL +(define ((false-or-op op) x) (and x (op x))) +(define* _string/utf-8 + (make-ctype _bytes + (false-or-op string->bytes/utf-8) (false-or-op bytes->string/utf-8))) +(define* _string/locale + (make-ctype _bytes + (false-or-op string->bytes/locale) (false-or-op bytes->string/locale))) +(define* _string/latin-1 + (make-ctype _bytes + (false-or-op string->bytes/latin-1) (false-or-op bytes->string/latin-1))) + +;; 8-bit string encodings, #f is NULL, can also use bytes and paths +(define ((any-string-op op) x) + (cond [(not x) x] + [(bytes? x) x] + [(path? x) (path->bytes x)] + [else (op x)])) +(define* _string*/utf-8 + (make-ctype _bytes + (any-string-op string->bytes/utf-8) (false-or-op bytes->string/utf-8))) +(define* _string*/locale + (make-ctype _bytes + (any-string-op string->bytes/locale) (false-or-op bytes->string/locale))) +(define* _string*/latin-1 + (make-ctype _bytes + (any-string-op string->bytes/latin-1) (false-or-op bytes->string/latin-1))) + +;; A generic _string type that usually does the right thing via a parameter +(define* default-_string-type + (make-parameter _string*/utf-8 + (lambda (x) + (if (ctype? x) + x (error 'default-_string-type "expecting a C type, got ~e" x))))) +;; The type looks like an identifier, but it's actually using the parameter +(provide _string) +(define-syntax _string + (syntax-id-rules () + [(_ . xs) ((default-_string-type) . xs)] + [_ (default-_string-type)])) + +;; _symbol is defined in C, since it uses simple C strings +(provide _symbol) + +(provide _path) +;; `file' type: path-expands a path string, provide _path too. +(define* _file (make-ctype _path cleanse-path #f)) + +;; `string/eof' type: converts an output #f (NULL) to an eof-object. +(define string-type->string/eof-type + (let ([table (make-hasheq)]) + (lambda (string-type) + (hash-ref table string-type + (lambda () + (let ([new-type (make-ctype string-type + (lambda (x) (and (not (eof-object? x)) x)) + (lambda (x) (or x eof)))]) + (hash-set! table string-type new-type) + new-type)))))) +(provide _string/eof _bytes/eof) +(define _bytes/eof + (make-ctype _bytes + (lambda (x) (and (not (eof-object? x)) x)) + (lambda (x) (or x eof)))) +(define-syntax _string/eof ; make it a syntax so it depends on the _string type + (syntax-id-rules () + [(_ . xs) ((string-type->string/eof-type _string) . xs)] + [_ (string-type->string/eof-type _string)])) + +;; ---------------------------------------------------------------------------- +;; Utility types + +;; Call this with a name (symbol) and a list of symbols, where a symbol can be +;; followed by a '= and an integer to have a similar effect of C's enum. +(define (_enum* name symbols . base?) + (define basetype (if (pair? base?) (car base?) _ufixint)) + (define sym->int '()) + (define int->sym '()) + (define s->c + (if name (string->symbol (format "enum:~a->int" name)) 'enum->int)) + (let loop ([i 0] [symbols symbols]) + (unless (null? symbols) + (let-values ([(i rest) + (if (and (pair? (cdr symbols)) + (eq? '= (cadr symbols)) + (pair? (cddr symbols))) + (values (caddr symbols) + (cdddr symbols)) + (values i + (cdr symbols)))]) + (set! sym->int (cons (cons (car symbols) i) sym->int)) + (set! int->sym (cons (cons i (car symbols)) int->sym)) + (loop (add1 i) rest)))) + (make-ctype basetype + (lambda (x) + (let ([a (assq x sym->int)]) + (if a + (cdr a) + (raise-type-error s->c (format "~a" (or name "enum")) x)))) + (lambda (x) (cond [(assq x int->sym) => cdr] [else #f])))) + +;; Macro wrapper -- no need for a name +(provide _enum) +(define-syntax (_enum stx) + (syntax-case stx () + [(_ syms) + (with-syntax ([name (syntax-local-name)]) + #'(_enum* 'name syms))] + [(_ syms basetype) + (with-syntax ([name (syntax-local-name)]) + #'(_enum* 'name syms basetype))] + [id (identifier? #'id) + #'(lambda (syms . base?) (apply _enum* #f syms base?))])) + +;; Call this with a name (symbol) and a list of (symbol int) or symbols like +;; the above with '= -- but the numbers have to be specified in some way. The +;; generated type will convert a list of these symbols into the logical-or of +;; their values and back. +(define (_bitmask* name orig-symbols->integers . base?) + (define basetype (if (pair? base?) (car base?) _uint)) + (define s->c + (if name (string->symbol (format "bitmask:~a->int" name)) 'bitmask->int)) + (define symbols->integers + (let loop ([s->i orig-symbols->integers]) + (cond + [(null? s->i) + null] + [(and (pair? (cdr s->i)) (eq? '= (cadr s->i)) (pair? (cddr s->i))) + (cons (list (car s->i) (caddr s->i)) + (loop (cdddr s->i)))] + [(and (pair? (car s->i)) (pair? (cdar s->i)) (null? (cddar s->i)) + (symbol? (caar s->i)) (integer? (cadar s->i))) + (cons (car s->i) (loop (cdr s->i)))] + [else + (error '_bitmask "bad spec in ~e" orig-symbols->integers)]))) + (make-ctype basetype + (lambda (symbols) + (if (null? symbols) ; probably common + 0 + (let loop ([xs (if (pair? symbols) symbols (list symbols))] [n 0]) + (cond [(null? xs) n] + [(assq (car xs) symbols->integers) => + (lambda (x) (loop (cdr xs) (bitwise-ior (cadr x) n)))] + [else (raise-type-error s->c (format "~a" (or name "bitmask")) + symbols)])))) + (lambda (n) + (if (zero? n) ; probably common + '() + (let loop ([s->i symbols->integers] [l '()]) + (if (null? s->i) + (reverse l) + (loop (cdr s->i) + (let ([i (cadar s->i)]) + (if (and (not (= i 0)) (= i (bitwise-and i n))) + (cons (caar s->i) l) + l))))))))) + +;; Macro wrapper -- no need for a name +(provide _bitmask) +(define-syntax (_bitmask stx) + (syntax-case stx () + [(_ syms) + (with-syntax ([name (syntax-local-name)]) + #'(_bitmask* 'name syms))] + [(_ syms basetype) + (with-syntax ([name (syntax-local-name)]) + #'(_bitmask* 'name syms basetype))] + [id (identifier? #'id) + #'(lambda (syms . base?) (apply _bitmask* #f syms base?))])) + +;; ---------------------------------------------------------------------------- +;; Custom function type macros + +;; These macros get expanded by the _fun type. They can expand to a form that +;; looks like (keyword: value ...), where the keyword is one of: +;; * `type:' for the type that will be used, +;; * `expr:' an expression that will always be used for these arguments, as +;; if `= expr' is always given, when an expression is actually +;; given in an argument specification, it supersedes this. +;; * `bind:' for an additional binding that holds the initial value, +;; * `1st-arg:' is used to name an identifier that will be bound to the value +;; of the 1st foreign argument in pre/post chunks (good for +;; common cases where the first argument has a special meaning, +;; eg, for method calls), +;; * `prev-arg:' similar to 1st-arg: but for the previous argument, +;; * `pre:' for a binding that will be inserted before the ffi call, +;; * `post:' for a binding after the ffi call. +;; The pre: and post: bindings can be of the form (id => expr) to use the +;; existing value. Note that if the pre: expression is not (id => expr), then +;; it means that there is no input for this argument. Also note that if a +;; custom type is used as an output type of a function, then only the post: +;; code is used -- for example, this is useful for foreign functions that +;; allocate a memory block and return it to the user. The resulting wrapper +;; looks like: +;; (let* (...bindings for arguments... +;; ...bindings for bind: identifiers... +;; ...bindings for pre-code... +;; (ret-name ffi-call) +;; ...bindings for post-code...) +;; return-expression) +;; +;; Finally, the code in a custom-function macro needs special treatment when it +;; comes to dealing with code certificates, so instead of using +;; `define-syntax', you should use `define-fun-syntax' (used in the same way). + +;; _? +;; This is not a normal ffi type -- it is a marker for expressions that should +;; not be sent to the ffi function. Use this to bind local values in a +;; computation that is part of an ffi wrapper interface. +(provide _?) +(define-fun-syntax _? + (syntax-id-rules () [(_ . xs) ((type: #f) . xs)] [_ (type: #f)])) + +;; (_ptr ) +;; This is for pointers, where mode indicates input or output pointers (or +;; both). If the mode is `o' (output), then the wrapper will not get an +;; argument for it, instead it generates the matching argument. +(provide _ptr) +(define-fun-syntax _ptr + (syntax-rules (i o io) + [(_ i t) (type: _pointer + pre: (x => (let ([p (malloc t)]) (ptr-set! p t x) p)))] + [(_ o t) (type: _pointer + pre: (malloc t) + post: (x => (ptr-ref x t)))] + [(_ io t) (type: _pointer + pre: (x => (let ([p (malloc t)]) (ptr-set! p t x) p)) + post: (x => (ptr-ref x t)))])) + +;; (_box ) +;; This is similar to a (_ptr io ) argument, where the input is expected +;; to be a box, which is unboxed on entry and modified on exit. +(provide _box) +(define-fun-syntax _box + (syntax-rules () + [(_ t) (type: _pointer + bind: tmp ; need to save the box so we can get back to it + pre: (x => (let ([p (malloc t)]) (ptr-set! p t (unbox x)) p)) + post: (x => (begin (set-box! tmp (ptr-ref x t)) tmp)))])) + +;; (_list []) +;; Similar to _ptr, except that it is used for converting lists to/from C +;; vectors. The length is needed for output values where it is used in the +;; post code, and in the pre code of an output mode to allocate the block. In +;; any case it can refer to a previous binding for the length of the list which +;; the C function will most likely require. +(provide _list) +(define-fun-syntax _list + (syntax-rules (i o io) + [(_ i t ) (type: _pointer + pre: (x => (list->cblock x t)))] + [(_ o t n) (type: _pointer + pre: (malloc n t) + post: (x => (cblock->list x t n)))] + [(_ io t n) (type: _pointer + pre: (x => (list->cblock x t)) + post: (x => (cblock->list x t n)))])) + +;; (_vector []) +;; Same as _list, except that it uses Scheme vectors. +(provide _vector) +(define-fun-syntax _vector + (syntax-rules (i o io) + [(_ i t ) (type: _pointer + pre: (x => (vector->cblock x t)))] + [(_ o t n) (type: _pointer + pre: (malloc n t) + post: (x => (cblock->vector x t n)))] + [(_ io t n) (type: _pointer + pre: (x => (vector->cblock x t)) + post: (x => (cblock->vector x t n)))])) + +;; _bytes or (_bytes o n) is for a memory block represented as a Scheme byte +;; string. _bytes is just like a byte-string, and (_bytes o n) is for +;; pre-malloc of the string. There is no need for other modes: i or io would +;; be just like _bytes since the string carries its size information (so there +;; is no real need for the `o', but it's there for consistency with the above +;; macros). +(provide (rename-out [_bytes* _bytes])) +(define-fun-syntax _bytes* + (syntax-id-rules (o) + [(_ o n) (type: _bytes + pre: (make-sized-byte-string (malloc n) n) + ;; post is needed when this is used as a function output type + post: (x => (make-sized-byte-string x n)))] + [(_ . xs) (_bytes . xs)] + [_ _bytes])) + +;; ---------------------------------------------------------------------------- +;; Safe raw vectors + +(define-struct cvector (ptr type length)) + +(provide* cvector? cvector-length cvector-type cvector-ptr + ;; make-cvector* is a dangerous operation + (unsafe (rename-out [make-cvector make-cvector*]))) + +(define _cvector* ; used only as input types + (make-ctype _pointer cvector-ptr + (lambda (x) + (error '_cvector + "cannot automatically convert a C pointer to a cvector")))) + +;; (_cvector [ ]) | _cevector +;; Same as _list etc above, except that it uses C vectors. +(provide _cvector) +(define-fun-syntax _cvector + (syntax-id-rules (i o io) + [(_ i ) _cvector*] + [(_ o t n) (type: _pointer ; needs to be a pointer, not a cvector* + pre: (malloc n t) + post: (x => (make-cvector x t n)))] + [(_ io ) (type: _cvector* + bind: tmp + pre: (x => (cvector-ptr x)) + post: (x => tmp))] + [(_ . xs) (_cvector* . xs)] + [_ _cvector*])) + +(provide (rename-out [allocate-cvector make-cvector])) +(define (allocate-cvector type len) + (make-cvector (if (zero? len) #f ; 0 => NULL + (malloc len type)) + type len)) + +(provide (rename-out [cvector-args cvector])) +(define (cvector-args type . args) + (list->cvector args type)) + +(define* (cvector-ref v i) + (if (and (exact-nonnegative-integer? i) (< i (cvector-length v))) + (ptr-ref (cvector-ptr v) (cvector-type v) i) + (error 'cvector-ref "bad index ~e for cvector bounds of 0..~e" + i (sub1 (cvector-length v))))) + +(define* (cvector-set! v i x) + (if (and (exact-nonnegative-integer? i) (< i (cvector-length v))) + (ptr-set! (cvector-ptr v) (cvector-type v) i x) + (error 'cvector-ref "bad index ~e for cvector bounds of 0..~e" + i (sub1 (cvector-length v))))) + +(define* (cvector->list v) + (cblock->list (cvector-ptr v) (cvector-type v) (cvector-length v))) + +(define* (list->cvector l type) + (make-cvector (list->cblock l type) type (length l))) + +;; ---------------------------------------------------------------------------- +;; SRFI-4 implementation + +(define-syntax (srfi-4-define/provide stx) + (syntax-case stx () + [(_ TAG type) + (identifier? #'TAG) + (let ([name (format "~avector" (syntax->datum #'TAG))]) + (define (id prefix suffix) + (let* ([name (if prefix (string-append prefix name) name)] + [name (if suffix (string-append name suffix) name)]) + (datum->syntax #'TAG (string->symbol name) #'TAG))) + (with-syntax ([TAG? (id "" "?")] + [TAG (id "" "")] + [s:TAG (id "s:" "")] + [make-TAG (id "make-" "")] + [TAG-ptr (id "" "-ptr")] + [TAG-length (id "" "-length")] + [allocate-TAG (id "allocate-" "")] + [TAG* (id "" "*")] + [list->TAG (id "list->" "")] + [TAG->list (id "" "->list")] + [TAG-ref (id "" "-ref")] + [TAG-set! (id "" "-set!")] + [_TAG (id "_" "")] + [_TAG* (id "_" "*")] + [TAGname name]) + #'(begin + (define-struct TAG (ptr length)) + (provide TAG? TAG-length (rename-out [TAG s:TAG])) + (provide (rename-out [allocate-TAG make-TAG])) + (define (allocate-TAG n . init) + (let* ([p (if (eq? n 0) #f (malloc n type))] + [v (make-TAG p n)]) + (when (and p (pair? init)) + (let ([init (car init)]) + (let loop ([i (sub1 n)]) + (unless (< i 0) + (ptr-set! p type i init) + (loop (sub1 i)))))) + v)) + (provide (rename-out [TAG* TAG])) + (define (TAG* . vals) + (list->TAG vals)) + (define* (TAG-ref v i) + (if (TAG? v) + (if (and (exact-nonnegative-integer? i) (< i (TAG-length v))) + (ptr-ref (TAG-ptr v) type i) + (error 'TAG-ref "bad index ~e for ~a bounds of 0..~e" + i 'TAG (sub1 (TAG-length v)))) + (raise-type-error 'TAG-ref TAGname v))) + (define* (TAG-set! v i x) + (if (TAG? v) + (if (and (exact-nonnegative-integer? i) (< i (TAG-length v))) + (ptr-set! (TAG-ptr v) type i x) + (error 'TAG-set! "bad index ~e for ~a bounds of 0..~e" + i 'TAG (sub1 (TAG-length v)))) + (raise-type-error 'TAG-set! TAGname v))) + (define* (TAG->list v) + (if (TAG? v) + (cblock->list (TAG-ptr v) type (TAG-length v)) + (raise-type-error 'TAG->list TAGname v))) + (define* (list->TAG l) + (make-TAG (list->cblock l type) (length l))) + ;; same as the _cvector implementation + (provide _TAG) + (define _TAG* + (make-ctype _pointer TAG-ptr + (lambda (x) + (error + '_TAG + "cannot automatically convert a C pointer to a ~a" + TAGname)))) + (define-fun-syntax _TAG + (syntax-id-rules (i o io) + [(_ i ) _TAG*] + [(_ o n) (type: _pointer + pre: (malloc n type) + post: (x => (make-TAG x n)))] + [(_ io ) (type: _cvector* + bind: tmp + pre: (x => (TAG-ptr x)) + post: (x => tmp))] + [(_ . xs) (_TAG* . xs)] + [_ _TAG*])))))] + [(_ TAG type) + (identifier? #'TAG)])) + +;; check that the types that were used above have the proper sizes +(unless (= 4 (ctype-sizeof _float)) + (error 'foreign "internal error: float has a bad size (~s)" + (ctype-sizeof _float))) +(unless (= 8 (ctype-sizeof _double*)) + (error 'foreign "internal error: double has a bad size (~s)" + (ctype-sizeof _double*))) + +(srfi-4-define/provide s8 _int8) +(srfi-4-define/provide s16 _int16) +(srfi-4-define/provide u16 _uint16) +(srfi-4-define/provide s32 _int32) +(srfi-4-define/provide u32 _uint32) +(srfi-4-define/provide s64 _int64) +(srfi-4-define/provide u64 _uint64) +(srfi-4-define/provide f32 _float) +(srfi-4-define/provide f64 _double*) + +;; simply rename bytes* to implement the u8vector type +(provide (rename-out [bytes? u8vector? ] + [bytes-length u8vector-length] + [make-bytes make-u8vector ] + [bytes u8vector ] + [bytes-ref u8vector-ref ] + [bytes-set! u8vector-set! ] + [bytes->list u8vector->list ] + [list->bytes list->u8vector ] + [_bytes _u8vector ])) +;; additional `u8vector' bindings for srfi-66 +(provide (rename-out [bytes-copy u8vector-copy] [bytes=? u8vector=?])) +(define* (u8vector-compare v1 v2) + (cond [(bytes? v1 v2) 1] + [else 0])) +(define* (u8vector-copy! src src-start dest dest-start n) + (bytes-copy! dest dest-start src src-start (+ src-start n))) + +;; ---------------------------------------------------------------------------- +;; Tagged pointers + +;; Make these operations available for unsafe interfaces (they can be used to +;; grab a hidden tag value and break code). +(provide* (unsafe cpointer-tag) (unsafe set-cpointer-tag!) + (unsafe cpointer-has-tag?) (unsafe cpointer-push-tag!)) + +;; Defined as syntax for efficiency, but can be used as procedures too. +(define-syntax (cpointer-has-tag? stx) + (syntax-case stx () + [(_ cptr tag) + #'(let ([ptag (cpointer-tag cptr)]) + (if (pair? ptag) (memq tag ptag) (eq? tag ptag)))] + [id (identifier? #'id) + #'(lambda (cptr tag) (cpointer-has-tag? cptr tag))])) +(define-syntax (cpointer-push-tag! stx) + (syntax-case stx () + [(_ cptr tag) + #'(let ([ptag (cpointer-tag cptr)]) + (set-cpointer-tag! cptr + (cond [(not ptag) tag] + [(pair? ptag) (cons tag ptag)] + [else (list tag ptag)])))] + [id (identifier? #'id) + #'(lambda (cptr tag) (cpointer-push-tag! cptr tag))])) + +(define (cpointer-maker nullable?) + (case-lambda + [(tag) ((cpointer-maker nullable?) tag #f #f #f)] + [(tag ptr-type) ((cpointer-maker nullable?) tag ptr-type #f #f)] + [(tag ptr-type scheme->c c->scheme) + (let* ([tag->C (string->symbol (format "~a->C" tag))] + [error-str (format "~a`~a' pointer" + (if nullable? "" "non-null ") tag)] + [error* (lambda (p) (raise-type-error tag->C error-str p))]) + (define-syntax-rule (tag-or-error ptr t) + (let ([p ptr]) + (if (cpointer? p) + (if (cpointer-has-tag? p t) p (error* p)) + (error* p)))) + (define-syntax-rule (tag-or-error/null ptr t) + (let ([p ptr]) + (if (cpointer? p) + (and p (if (cpointer-has-tag? p t) p (error* p))) + (error* p)))) + (make-ctype (or ptr-type _pointer) + ;; bad hack: `if's outside the lambda for efficiency + (if nullable? + (if scheme->c + (lambda (p) (tag-or-error/null (scheme->c p) tag)) + (lambda (p) (tag-or-error/null p tag))) + (if scheme->c + (lambda (p) (tag-or-error (scheme->c p) tag)) + (lambda (p) (tag-or-error p tag)))) + (if nullable? + (if c->scheme + (lambda (p) (when p (cpointer-push-tag! p tag)) (c->scheme p)) + (lambda (p) (when p (cpointer-push-tag! p tag)) p)) + (if c->scheme + (lambda (p) + (if p (cpointer-push-tag! p tag) (error* p)) + (c->scheme p)) + (lambda (p) + (if p (cpointer-push-tag! p tag) (error* p)) + p)))))])) + +;; This is a kind of a pointer that gets a specific tag when converted to +;; Scheme, and accepts only such tagged pointers when going to C. An optional +;; `ptr-type' can be given to be used as the base pointer type, instead of +;; _pointer, `scheme->c' and `c->scheme' can be used for adding conversion +;; hooks. +(define* _cpointer (cpointer-maker #f)) + +;; Similar to the above, but can tolerate null pointers (#f). +(define* _cpointer/null (cpointer-maker #t)) + +;; A macro version of the above two functions, using the defined name for a tag +;; string, and defining a predicate too. The name should look like `_foo', the +;; predicate will be `foo?', and the tag will be "foo". In addition, `foo-tag' +;; is bound to the tag. The optional `ptr-type', `scheme->c', and `c->scheme' +;; arguments are the same as those of `_cpointer'. `_foo' will be bound to the +;; _cpointer type, and `_foo/null' to the _cpointer/null type. +(provide define-cpointer-type) +(define-syntax (define-cpointer-type stx) + (syntax-case stx () + [(_ _TYPE) #'(define-cpointer-type _TYPE #f #f #f)] + [(_ _TYPE ptr-type) #'(define-cpointer-type _TYPE ptr-type #f #f)] + [(_ _TYPE ptr-type scheme->c c->scheme) + (and (identifier? #'_TYPE) + (regexp-match #rx"^_.+" (symbol->string (syntax-e #'_TYPE)))) + (let ([name (cadr (regexp-match #rx"^_(.+)$" + (symbol->string (syntax-e #'_TYPE))))]) + (define (id . strings) + (datum->syntax + #'_TYPE (string->symbol (apply string-append strings)) #'_TYPE)) + (with-syntax ([name-string name] + [TYPE? (id name "?")] + [TYPE-tag (id name "-tag")] + [_TYPE/null (id "_" name "/null")]) + #'(define-values (_TYPE _TYPE/null TYPE? TYPE-tag) + (let ([TYPE-tag name-string]) + (values (_cpointer TYPE-tag ptr-type scheme->c c->scheme) + (_cpointer/null TYPE-tag ptr-type scheme->c c->scheme) + (lambda (x) + (and (cpointer? x) (cpointer-has-tag? x TYPE-tag))) + TYPE-tag)))))])) + +;; ---------------------------------------------------------------------------- +;; Struct wrappers + +(define (compute-offsets types) + (let loop ([ts types] [cur 0] [r '()]) + (if (null? ts) + (reverse r) + (let* ([algn (ctype-alignof (car ts))] + [pos (+ cur (modulo (- (modulo cur algn)) algn))]) + (loop (cdr ts) + (+ pos (ctype-sizeof (car ts))) + (cons pos r)))))) + +;; Simple structs: call this with a list of types, and get a type that marshals +;; C structs to/from Scheme lists. +(define* (_list-struct . types) + (let ([stype (make-cstruct-type types)] + [offsets (compute-offsets types)] + [len (length types)]) + (make-ctype stype + (lambda (vals) + (unless (and (list vals) (= len (length vals))) + (raise-type-error 'list-struct (format "list of ~a items" len) vals)) + (let ([block (malloc stype)]) + (for-each (lambda (type ofs val) (ptr-set! block type 'abs ofs val)) + types offsets vals) + block)) + (lambda (block) + (map (lambda (type ofs) (ptr-ref block type 'abs ofs)) + types offsets))))) + +;; (define-cstruct _foo ([slot type] ...)) +;; or +;; (define-cstruct (_foo _super) ([slot type] ...)) +;; defines a type called _foo for a C struct, with user-procedues: make-foo, +;; foo? foo-slot... and set-foo-slot!.... The `_' prefix is required. Objects +;; of this new type are actually cpointers, with a type tag that is "foo" and +;; (possibly more if the first type is itself a cstruct type or if a super type +;; is given,) provided as foo-tag, and tags of pointers are checked before +;; attempting to use them (see define-cpointer-type above). Note that since +;; structs are implemented as pointers, they can be used for a _pointer input +;; to a foreign function: their address will be used, to make this possible, +;; the corresponding cpointer type is defined as _foo-pointer. If a super +;; cstruct type is given, the constructor function expects values for every +;; field of the super type as well as other fields that are specified, and a +;; slot named `super' can be used to extract this initial struct -- although +;; pointers to the new struct type can be used as pointers to the super struct +;; type. +(provide define-cstruct) +(define-syntax (define-cstruct stx) + (define (make-syntax _TYPE-stx has-super? slot-names-stx slot-types-stx) + (define name + (cadr (regexp-match #rx"^_(.+)$" (symbol->string (syntax-e _TYPE-stx))))) + (define slot-names (map (lambda (x) (symbol->string (syntax-e x))) + (syntax->list slot-names-stx))) + (define 1st-type + (let ([xs (syntax->list slot-types-stx)]) (and (pair? xs) (car xs)))) + (define (id . strings) + (datum->syntax + _TYPE-stx (string->symbol (apply string-append strings)) _TYPE-stx)) + (define (ids name-func) + (map (lambda (s) + (datum->syntax + _TYPE-stx + (string->symbol (apply string-append (name-func s))) + _TYPE-stx)) + slot-names)) + (define (safe-id=? x y) + (and (identifier? x) (identifier? y) (free-identifier=? x y))) + (with-syntax + ([has-super? has-super?] + [name-string name] + [struct-string (format "struct:~a" name)] + [(slot ...) slot-names-stx] + [(slot-type ...) slot-types-stx] + [_TYPE _TYPE-stx] + [_TYPE-pointer (id "_"name"-pointer")] + [_TYPE-pointer/null (id "_"name"-pointer/null")] + [_TYPE/null (id "_"name"/null")] + [_TYPE* (id "_"name"*")] + [TYPE? (id name"?")] + [make-TYPE (id "make-"name)] + [list->TYPE (id "list->"name)] + [list*->TYPE (id "list*->"name)] + [TYPE->list (id name"->list")] + [TYPE->list* (id name"->list*")] + [TYPE-tag (id name"-tag")] + [(stype ...) (ids (lambda (s) `(,name"-",s"-type")))] + [(TYPE-SLOT ...) (ids (lambda (s) `(,name"-",s)))] + [(set-TYPE-SLOT! ...) (ids (lambda (s) `("set-",name"-",s"!")))] + [(offset ...) (generate-temporaries + (ids (lambda (s) `(,s"-offset"))))]) + (with-syntax ([get-super-info + ;; the 1st-type might be a pointer to this type + (if (or (safe-id=? 1st-type #'_TYPE-pointer/null) + (safe-id=? 1st-type #'_TYPE-pointer)) + #'(values #f '() #f #f #f #f) + #`(cstruct-info #,1st-type + (lambda () (values #f '() #f #f #f #f))))]) + #'(define-values (_TYPE _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag + make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ... + list->TYPE list*->TYPE TYPE->list TYPE->list*) + (let-values ([(super-pointer super-tags super-types super-offsets + super->list* list*->super) + get-super-info]) + (define-cpointer-type _TYPE super-pointer) + ;; these makes it possible to use recursive pointer definitions + (define _TYPE-pointer _TYPE) + (define _TYPE-pointer/null _TYPE/null) + (let*-values ([(stype ...) (values slot-type ...)] + [(types) (list stype ...)] + [(offsets) (compute-offsets types)] + [(offset ...) (apply values offsets)]) + (define all-tags (cons TYPE-tag super-tags)) + (define _TYPE* + ;; c->scheme adjusts all tags + (let* ([cst (make-cstruct-type types)] + [t (_cpointer TYPE-tag cst)] + [c->s (ctype-c->scheme t)]) + (make-ctype cst (ctype-scheme->c t) + ;; hack: modify & reuse the procedure made by _cpointer + (lambda (p) + (if p (set-cpointer-tag! p all-tags) (c->s p)) + p)))) + (define-values (all-types all-offsets) + (if (and has-super? super-types super-offsets) + (values (append super-types (cdr types)) + (append super-offsets (cdr offsets))) + (values types offsets))) + (define (TYPE-SLOT x) + (unless (TYPE? x) + (raise-type-error 'TYPE-SLOT struct-string x)) + (ptr-ref x stype 'abs offset)) + ... + (define (set-TYPE-SLOT! x slot) + (unless (TYPE? x) + (raise-type-error 'set-TYPE-SLOT! struct-string 0 x slot)) + (ptr-set! x stype 'abs offset slot)) + ... + (define make-TYPE + (if (and has-super? super-types super-offsets) + ;; init using all slots + (lambda vals + (if (= (length vals) (length all-types)) + (let ([block (malloc _TYPE*)]) + (set-cpointer-tag! block all-tags) + (for-each (lambda (type ofs value) + (ptr-set! block type 'abs ofs value)) + all-types all-offsets vals) + block) + (error '_TYPE "expecting ~s values, got ~s: ~e" + (length all-types) (length vals) vals))) + ;; normal initializer + (lambda (slot ...) + (let ([block (malloc _TYPE*)]) + (set-cpointer-tag! block all-tags) + (ptr-set! block stype 'abs offset slot) + ... + block)))) + (define (list->TYPE vals) (apply make-TYPE vals)) + (define (list*->TYPE vals) + (cond + [(TYPE? vals) vals] + [(= (length vals) (length all-types)) + (let ([block (malloc _TYPE*)]) + (set-cpointer-tag! block all-tags) + (for-each + (lambda (type ofs value) + (let-values + ([(ptr tags types offsets T->list* list*->T) + (cstruct-info + type + (lambda () (values #f '() #f #f #f #f)))]) + (ptr-set! block type 'abs ofs + (if list*->T (list*->T value) value)))) + all-types all-offsets vals) + block)] + [else (error '_TYPE "expecting ~s values, got ~s: ~e" + (length all-types) (length vals) vals)])) + (define (TYPE->list x) + (unless (TYPE? x) + (raise-type-error 'TYPE-list struct-string x)) + (map (lambda (type ofs) (ptr-ref x type 'abs ofs)) + all-types all-offsets)) + (define (TYPE->list* x) + (unless (TYPE? x) + (raise-type-error 'TYPE-list struct-string x)) + (map (lambda (type ofs) + (let-values + ([(v) (ptr-ref x type 'abs ofs)] + [(ptr tags types offsets T->list* list*->T) + (cstruct-info + type + (lambda () (values #f '() #f #f #f #f)))]) + (if T->list* (T->list* v) v))) + all-types all-offsets)) + (cstruct-info + _TYPE* 'set! + _TYPE all-tags all-types all-offsets TYPE->list* list*->TYPE) + (values _TYPE* _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag + make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ... + list->TYPE list*->TYPE TYPE->list TYPE->list*))))))) + (define (identifiers? stx) + (andmap identifier? (syntax->list stx))) + (define (_-identifier? id stx) + (and (identifier? id) + (or (regexp-match #rx"^_." (symbol->string (syntax-e id))) + (raise-syntax-error #f "cstruct name must begin with a `_'" + stx id)))) + (syntax-case stx () + [(_ _TYPE ([slot slot-type] ...)) + (and (_-identifier? #'_TYPE stx) + (identifiers? #'(slot ...))) + (make-syntax #'_TYPE #f #'(slot ...) #'(slot-type ...))] + [(_ (_TYPE _SUPER) ([slot slot-type] ...)) + (and (_-identifier? #'_TYPE stx) (identifiers? #'(slot ...))) + (with-syntax ([super (datum->syntax #'_TYPE 'super #'_TYPE)]) + (make-syntax #'_TYPE #t #'(super slot ...) #'(_SUPER slot-type ...)))])) + +;; helper for the above: keep runtime information on structs +(define cstruct-info + (let ([table (make-weak-hasheq)]) + (lambda (cstruct msg/fail-thunk . args) + (cond [(eq? 'set! msg/fail-thunk) + (hash-set! table cstruct (make-ephemeron cstruct args))] + [(and cstruct ; might get a #f if there were no slots + (hash-ref table cstruct (lambda () #f))) + => (lambda (xs) + (let ([v (ephemeron-value xs)]) + (if v (apply values v) (msg/fail-thunk))))] + [else (msg/fail-thunk)])))) + +;; ---------------------------------------------------------------------------- +;; + +(define prim-synonyms + #hasheq((double* . double) + (fixint . long) + (ufixint . ulong) + (fixnum . long) + (ufixnum . ulong) + (path . bytes) + (symbol . bytes) + (scheme . pointer))) + +(define (ctype->layout c) + (let ([b (ctype-basetype c)]) + (cond + [(ctype? b) (ctype->layout b)] + [(list? b) (map ctype->layout b)] + [else (hash-ref prim-synonyms b b)]))) + +;; ---------------------------------------------------------------------------- +;; Misc utilities + +;; Used by set-ffi-obj! to get the actual value so it can be kept around +(define (get-lowlevel-object x type) + (let ([basetype (ctype-basetype type)]) + (if (ctype? basetype) + (let ([s->c (ctype-scheme->c type)]) + (get-lowlevel-object (if s->c (s->c x) x) basetype)) + (values x type)))) + +;; Converting Scheme lists to/from C vectors (going back requires a length) +(define* (list->cblock l type) + (if (null? l) + #f ; null => NULL + (let ([cblock (malloc (length l) type)]) + (let loop ([l l] [i 0]) + (unless (null? l) + (ptr-set! cblock type i (car l)) + (loop (cdr l) (add1 i)))) + cblock))) +(provide* (unsafe cblock->list)) +(define (cblock->list cblock type len) + (cond [(zero? len) '()] + [(cpointer? cblock) + (let loop ([i (sub1 len)] [r '()]) + (if (< i 0) + r + (loop (sub1 i) (cons (ptr-ref cblock type i) r))))] + [else (error 'cblock->list + "expecting a non-void pointer, got ~s" cblock)])) + +;; Converting Scheme vectors to/from C vectors +(define* (vector->cblock v type) + (let ([len (vector-length v)]) + (if (zero? len) + #f ; #() => NULL + (let ([cblock (malloc len type)]) + (let loop ([i 0]) + (when (< i len) + (ptr-set! cblock type i (vector-ref v i)) + (loop (add1 i)))) + cblock)))) +(provide* (unsafe cblock->vector)) +(define (cblock->vector cblock type len) + (cond [(zero? len) '#()] + [(cpointer? cblock) + (let ([v (make-vector len)]) + (let loop ([i (sub1 len)]) + (unless (< i 0) + (vector-set! v i (ptr-ref cblock type i)) + (loop (sub1 i)))) + v)] + [else (error 'cblock->vector + "expecting a non-void pointer, got ~s" cblock)])) + +;; Useful for automatic definitions +;; If a provided regexp begins with a "^" or ends with a "$", then +;; `regexp-replace' is used, otherwise use `regexp-replace*'. +(define* (regexp-replaces x rs) + (let loop ([str (if (bytes? x) (bytes->string/utf-8 x) (format "~a" x))] + [rs rs]) + (if (null? rs) + str + (loop ((if (regexp-match #rx"^\\^|\\$$" + (if (regexp? (caar rs)) + (object-name (caar rs)) (caar rs))) + regexp-replace regexp-replace*) + (caar rs) str (cadar rs)) (cdr rs))))) + +;; A facility for running finalizers using executors. #%foreign has a C-based +;; version that uses finalizers, but that leads to calling Scheme from the GC +;; which is not a good idea. +(define killer-executor (make-will-executor)) +(define killer-thread #f) + +(define* (register-finalizer obj finalizer) + (unless killer-thread + (set! killer-thread + (thread (lambda () + (let loop () (will-execute killer-executor) (loop)))))) + (will-register killer-executor obj finalizer)) + +(define-unsafer unsafe!) diff --git a/collects/scheme/list.ss b/collects/scheme/list.ss index ec13a28140..cedd06621c 100644 --- a/collects/scheme/list.ss +++ b/collects/scheme/list.ss @@ -20,11 +20,12 @@ add-between remove-duplicates filter-map + count partition argmin argmax - + ;; convenience append-map filter-not) @@ -237,6 +238,27 @@ (let ([x (f (car l))]) (if x (cons x (loop (cdr l))) (loop (cdr l)))))))) +;; very similar to `filter-map', one more such function will justify some macro +(define (count f l . ls) + (unless (and (procedure? f) (procedure-arity-includes? f (add1 (length ls)))) + (raise-type-error + 'count (format "procedure (arity ~a)" (add1 (length ls))) f)) + (unless (and (list? l) (andmap list? ls)) + (raise-type-error + 'count "proper list" + (ormap (lambda (x) (and (not (list? x)) x)) (cons l ls)))) + (if (pair? ls) + (let ([len (length l)]) + (if (andmap (lambda (l) (= len (length l))) ls) + (let loop ([l l] [ls ls] [c 0]) + (if (null? l) + c + (loop (cdr l) (map cdr ls) + (if (apply f (car l) (map car ls)) (add1 c) c)))) + (error 'count "all lists must have same size"))) + (let loop ([l l] [c 0]) + (if (null? l) c (loop (cdr l) (if (f (car l)) (add1 c) c)))))) + ;; Originally from srfi-1 -- shares common tail with the input when possible ;; (define (partition f l) ;; (unless (and (procedure? f) (procedure-arity-includes? f 1)) diff --git a/collects/scheme/local.ss b/collects/scheme/local.ss index cb037855e0..88bd7fff69 100644 --- a/collects/scheme/local.ss +++ b/collects/scheme/local.ss @@ -1,66 +1,7 @@ #lang scheme/base - -(require (for-syntax scheme/base - syntax/context - syntax/kerncase)) - +(require (for-syntax scheme/base) + "private/local.ss") (provide local) (define-syntax (local stx) - (syntax-case stx () - [(_ (defn ...) body1 body ...) - (let ([defs (let ([expand-context (generate-expand-context)]) - (let loop ([defns (syntax->list (syntax (defn ...)))]) - (apply - append - (map - (lambda (defn) - (let ([d (local-expand - defn - expand-context - (kernel-form-identifier-list))] - [check-ids (lambda (ids) - (for-each - (lambda (id) - (unless (identifier? id) - (raise-syntax-error - #f - "not an identifier for definition" - stx - id))) - ids))]) - (syntax-case d (define-values define-syntaxes begin) - [(begin defn ...) - (loop (syntax->list (syntax (defn ...))))] - [(define-values (id ...) body) - (begin - (check-ids (syntax->list (syntax (id ...)))) - (list d))] - [(define-values . rest) - (raise-syntax-error - #f "ill-formed definition" stx d)] - [(define-syntaxes (id ...) body) - (begin - (check-ids (syntax->list (syntax (id ...)))) - (list d))] - [(define-syntaxes . rest) - (raise-syntax-error - #f "ill-formed definition" stx d)] - [_else - (raise-syntax-error - #f "not a definition" stx defn)]))) - defns))))]) - (let ([ids (apply append - (map - (lambda (d) - (syntax-case d () - [(_ ids . __) (syntax->list (syntax ids))])) - defs))]) - (let ([dup (check-duplicate-identifier ids)]) - (when dup - (raise-syntax-error #f "duplicate identifier" stx dup))) - (with-syntax ([(def ...) defs]) - (syntax/loc stx - (let () def ... (let () body1 body ...))))))] - [(_ x body1 body ...) - (raise-syntax-error #f "not a definition sequence" stx (syntax x))])) + (do-local stx #'letrec-syntaxes+values)) diff --git a/collects/scheme/math.ss b/collects/scheme/math.ss index 99346dc1cc..a98ccd613e 100644 --- a/collects/scheme/math.ss +++ b/collects/scheme/math.ss @@ -7,7 +7,7 @@ (provide pi sqr sgn conjugate - sinh cosh) + sinh cosh tanh) (define (sqr z) (* z z)) @@ -29,3 +29,5 @@ (define (cosh x) (/ (+ (exp x) (exp (- x))) 2.0)) + +(define (tanh x) (/ (sinh x) (cosh x))) diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index a6ae8f06ee..a9040846b5 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -148,10 +148,12 @@ (define-for-syntax not-in-a-class (lambda (stx) - (raise-syntax-error - #f - "use of a class keyword is not in a class" - stx))) + (if (eq? (syntax-local-context) 'expression) + (raise-syntax-error + #f + "use of a class keyword is not in a class" + stx) + (quasisyntax/loc stx (#%expression #,stx))))) (define-syntax define/provide-context-keyword (syntax-rules () diff --git a/collects/scheme/private/contract-guts.ss b/collects/scheme/private/contract-guts.ss index b998a7521e..2e84a67a27 100644 --- a/collects/scheme/private/contract-guts.ss +++ b/collects/scheme/private/contract-guts.ss @@ -356,7 +356,9 @@ (define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate)) (define (check-flat-named-contract predicate) (coerce-flat-contract 'flat-named-contract predicate)) (define (flat-named-contract name predicate) - (coerce-flat-contract 'flat-named-contract predicate) + (unless (and (procedure? predicate) + (procedure-arity-includes? predicate 1)) + (error 'flat-named-contract "expected a procedure of arity 1 as second argument, got ~e" predicate)) (make-predicate-contract name predicate)) ;; build-compound-type-name : (union contract symbol) ... -> (-> sexp) diff --git a/collects/scheme/private/local.ss b/collects/scheme/private/local.ss new file mode 100644 index 0000000000..62a4720405 --- /dev/null +++ b/collects/scheme/private/local.ss @@ -0,0 +1,104 @@ +#lang scheme/base +(require (for-syntax scheme/base) + (for-syntax syntax/context) + (for-syntax syntax/kerncase)) +(provide (for-syntax do-local)) + +(define-for-syntax (do-local stx letrec-syntaxes+values-id) + (syntax-case stx () + [(_ (defn ...) body1 body ...) + (let* ([def-ctx (syntax-local-make-definition-context)] + [defs (let ([expand-context (cons (gensym 'intdef) + (let ([orig-ctx (syntax-local-context)]) + (if (pair? orig-ctx) + orig-ctx + null)))]) + (let loop ([defns (syntax->list (syntax (defn ...)))]) + (apply + append + (map + (lambda (defn) + (let ([d (local-expand + defn + expand-context + (kernel-form-identifier-list) + def-ctx)] + [check-ids (lambda (defn ids) + (for-each + (lambda (id) + (unless (identifier? id) + (raise-syntax-error + #f + "not an identifier for definition" + defn + id))) + ids))]) + (syntax-case d (define-values define-syntaxes begin) + [(begin defn ...) + (loop (syntax->list (syntax (defn ...))))] + [(define-values (id ...) body) + (let ([ids (syntax->list (syntax (id ...)))]) + (check-ids d ids) + (syntax-local-bind-syntaxes ids #f def-ctx) + (list d))] + [(define-values . rest) + (raise-syntax-error + #f "ill-formed definition" stx d)] + [(define-syntaxes (id ...) rhs) + (let ([ids (syntax->list (syntax (id ...)))]) + (check-ids d ids) + (with-syntax ([rhs (local-transformer-expand + #'rhs + 'expression + null)]) + (syntax-local-bind-syntaxes ids #'rhs def-ctx) + (list (quasisyntax/loc d (define-syntaxes #,ids rhs)))))] + [(define-syntaxes . rest) + (raise-syntax-error + #f "ill-formed definition" stx d)] + [_else + (raise-syntax-error + #f "not a definition" stx defn)]))) + defns))))]) + (internal-definition-context-seal def-ctx) + (let ([ids (apply append + (map + (lambda (d) + (syntax-case d () + [(_ ids . __) (syntax->list (syntax ids))])) + defs))] + [vbindings (apply append + (map (lambda (d) + (syntax-case d (define-values) + [(define-values ids rhs) + (list #'(ids rhs))] + [_ null])) + defs))] + [sbindings (apply append + (map (lambda (d) + (syntax-case d (define-syntaxes) + [(define-syntaxes ids rhs) + (list #'(ids rhs))] + [_ null])) + defs))]) + (let ([dup (check-duplicate-identifier ids)]) + (when dup + (raise-syntax-error #f "duplicate identifier" stx dup))) + (with-syntax ([sbindings sbindings] + [vbindings vbindings] + [LSV letrec-syntaxes+values-id] + [(body ...) + (map (lambda (stx) + ;; add def-ctx: + (let ([q (local-expand #`(quote #,stx) + 'expression + (list #'quote) + def-ctx)]) + (syntax-case q () + [(_ stx) #'stx]))) + (syntax->list #'(body1 body ...)))]) + (syntax/loc stx + (LSV sbindings vbindings + body ...)))))] + [(_ x body1 body ...) + (raise-syntax-error #f "not a definition sequence" stx (syntax x))])) diff --git a/collects/scheme/private/reqprov.ss b/collects/scheme/private/reqprov.ss index c1fa40a40c..bd2c9518d9 100644 --- a/collects/scheme/private/reqprov.ss +++ b/collects/scheme/private/reqprov.ss @@ -317,12 +317,12 @@ (syntax->list #'(elem ...))))] [_ (transform-simple in 0 #| run phase |#)]))]) (syntax-case stx () - [(_ in ...) - (with-syntax ([(new-in ...) - (apply append - (map transform-one (syntax->list #'(in ...))))]) + [(_ in) + (with-syntax ([(new-in ...) (transform-one #'in)]) (syntax/loc stx - (#%require new-in ...)))]))) + (#%require new-in ...)))] + [(_ in ...) + (syntax/loc stx (begin (require in) ...))]))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; require transformers @@ -653,7 +653,16 @@ (memq 0 modes)) (map (lambda (id) (make-export id (syntax-e id) 0 #f stx)) - (filter (same-ctx? free-identifier=?) + (filter (lambda (id) + (and ((same-ctx? free-identifier=?) id) + (let-values ([(v id) (syntax-local-value/immediate + id + (lambda () (values #f #f)))]) + (not + (and (rename-transformer? v) + (syntax-property + (rename-transformer-target v) + 'not-provide-all-defined)))))) ids)) null)))])))) diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss index df7b0766c8..935a7273d6 100644 --- a/collects/scheme/sandbox.ss +++ b/collects/scheme/sandbox.ss @@ -627,6 +627,7 @@ (define user-thread #t) ; set later to the thread (define user-done-evt #t) ; set in the same place (define terminated? #f) ; set to an exception value when the sandbox dies + (define breaks-originally-enabled? (break-enabled)) (define (limit-thunk thunk) (let* ([sec (and limits (car limits))] [mb (and limits (cadr limits))] @@ -665,42 +666,67 @@ (define (user-break) (when user-thread (break-thread user-thread))) (define (user-process) - (with-handlers ([void (lambda (exn) (channel-put result-ch exn))]) - ;; first set up the environment - (init-hook) - ((sandbox-init-hook)) - ;; now read and evaluate the input program - (evaluate-program - (if (procedure? program-maker) (program-maker) program-maker) - limit-thunk - (and coverage? (lambda (es+get) (set! uncovered es+get)))) - (channel-put result-ch 'ok)) - (set! eval-handler (cadr (sandbox-eval-handlers))) ; interactions handler - ;; finally wait for interaction expressions - (let ([n 0]) - (let loop () - (let ([expr (channel-get input-ch)]) - (when (eof-object? expr) - (terminated! 'eof) (channel-put result-ch expr) (user-kill)) - (with-handlers ([void (lambda (exn) - (channel-put result-ch (cons 'exn exn)))]) - (define run - (if (evaluator-message? expr) - (case (evaluator-message-msg expr) - [(thunk) (limit-thunk (car (evaluator-message-args expr)))] - [(thunk*) (car (evaluator-message-args expr))] - [else (error 'sandbox "internal error (bad message)")]) - (limit-thunk - (lambda () - (set! n (add1 n)) - (eval* (map (lambda (expr) (cons '#%top-interaction expr)) - (input->code (list expr) 'eval n))))))) - (channel-put result-ch (cons 'vals (call-with-values run list)))) - (loop))))) + (let ([break-paramz (current-break-parameterization)]) + (parameterize-break + #f ;; disable breaks during administrative work + (with-handlers ([void (lambda (exn) (channel-put result-ch exn))]) + (call-with-break-parameterization + break-paramz + (lambda () + ;; enable breaks, maybe + (when breaks-originally-enabled? (break-enabled #t)) + ;; first set up the environment + (init-hook) + ((sandbox-init-hook)) + ;; now read and evaluate the input program + (evaluate-program + (if (procedure? program-maker) (program-maker) program-maker) + limit-thunk + (and coverage? (lambda (es+get) (set! uncovered es+get)))))) + (channel-put result-ch 'ok)) + (set! eval-handler (cadr (sandbox-eval-handlers))) ; interactions handler + ;; finally wait for interaction expressions + (let ([n 0]) + (let loop () + (let ([expr (channel-get input-ch)]) + (when (eof-object? expr) + (terminated! 'eof) (channel-put result-ch expr) (user-kill)) + (with-handlers ([void (lambda (exn) + (channel-put result-ch (cons 'exn exn)))]) + (define run + (if (evaluator-message? expr) + (case (evaluator-message-msg expr) + [(thunk) (limit-thunk (car (evaluator-message-args expr)))] + [(thunk*) (car (evaluator-message-args expr))] + [else (error 'sandbox "internal error (bad message)")]) + (limit-thunk + (lambda () + (set! n (add1 n)) + (eval* (map (lambda (expr) (cons '#%top-interaction expr)) + (input->code (list expr) 'eval n))))))) + (channel-put result-ch (cons 'vals + (call-with-break-parameterization + break-paramz + (lambda () + (call-with-values run list)))))) + (loop))))))) (define (get-user-result) - (with-handlers ([(if (sandbox-propagate-breaks) exn:break? (lambda (_) #f)) - (lambda (e) (user-break) (get-user-result))]) - (sync user-done-evt result-ch))) + (if (and (sandbox-propagate-breaks) + ;; The following test is weird. We reliably catch breaks if breaks + ;; are enabled, except that a break just before or after isn't + ;; reliably propagated. A `get-result/enable-breaks' function + ;; would make more sense. + (break-enabled)) + ;; The following loop ensures that breaks are disabled while trying + ;; to handle a break, which ensures that we don't fail to + ;; propagate a break. + (parameterize-break + #f + (let loop () + (with-handlers* ([exn:break? (lambda (e) (user-break) (loop))]) + (sync/enable-break user-done-evt result-ch)))) + ;; The simple case doesn't have to deal with breaks: + (sync user-done-evt result-ch))) (define (user-eval expr) ;; the thread will usually be running, but it might be killed outside of ;; the sandboxed environment, for example, if you do something like @@ -856,7 +882,9 @@ ;; evaluates the program in `run-in-bg') -- so this parameterization ;; must be nested in the above (which is what paramaterize* does), or ;; it will not use the new namespace. - [current-eventspace (make-eventspace)]) + [current-eventspace (parameterize-break + #f + (make-eventspace))]) (let ([t (bg-run->thread (run-in-bg user-process))]) (set! user-done-evt (handle-evt t (lambda (_) (terminate+kill! #t #t)))) (set! user-thread t)) diff --git a/collects/scheme/splicing.ss b/collects/scheme/splicing.ss index 725283c4f8..da675688ac 100644 --- a/collects/scheme/splicing.ss +++ b/collects/scheme/splicing.ss @@ -2,51 +2,54 @@ (require (for-syntax scheme/base syntax/kerncase) "stxparam.ss" - "private/stxparam.ss") + "private/stxparam.ss" + "private/local.ss") (provide splicing-let-syntax splicing-let-syntaxes splicing-letrec-syntax splicing-letrec-syntaxes + splicing-let + splicing-let-values + splicing-letrec + splicing-letrec-values + splicing-letrec-syntaxes+values + splicing-local splicing-syntax-parameterize) -(define-for-syntax (do-let-syntax stx rec? multi? let-stx-id) +(define-for-syntax ((check-id stx) id-stx) + (unless (identifier? id-stx) + (raise-syntax-error #f "expected an identifier" stx id-stx)) + (list id-stx)) + +(define-for-syntax ((check-ids stx) ids-stx) + (let ([ids (syntax->list ids-stx)]) + (unless ids + (raise-syntax-error + #f + "expected a parenthesized sequence of identifiers" + stx + ids-stx)) + (for-each (check-id stx) ids) + ids)) + +(define-for-syntax (check-dup-binding stx idss) + (let ([dup-id (check-duplicate-identifier (apply append idss))]) + (when dup-id + (raise-syntax-error #f "duplicate binding" stx dup-id)))) + +(define-for-syntax (do-let-syntax stx rec? multi? let-id def-id need-top-decl?) (syntax-case stx () [(_ ([ids expr] ...) body ...) - (let ([all-ids (map (lambda (ids-stx) - (let ([ids (if multi? - (syntax->list ids-stx) - (list ids-stx))]) - (unless ids - (raise-syntax-error - #f - "expected a parenthesized sequence of identifiers" - stx - ids-stx)) - (for-each (lambda (id) - (unless (identifier? id) - (raise-syntax-error - #f - "expected an identifier" - stx - id))) - ids) - ids)) + (let ([all-ids (map ((if multi? check-ids check-id) stx) (syntax->list #'(ids ...)))]) - (let ([dup-id (check-duplicate-identifier - (apply append all-ids))]) - (when dup-id - (raise-syntax-error - #f - "duplicate binding" - stx - dup-id))) + (check-dup-binding stx all-ids) (if (eq? 'expression (syntax-local-context)) - (with-syntax ([let-stx let-stx-id]) + (with-syntax ([LET let-id]) (syntax/loc stx - (let-stx ([ids expr] ...) - (#%expression body) - ...))) + (LET ([ids expr] ...) + (#%expression body) + ...))) (let ([def-ctx (syntax-local-make-definition-context)] [ctx (list (gensym 'intdef))]) (syntax-local-bind-syntaxes (apply append all-ids) #f def-ctx) @@ -69,23 +72,97 @@ (map add-context exprs) exprs))] [(body ...) - (map add-context (syntax->list #'(body ...)))]) - #'(begin - (define-syntaxes (id ...) expr) - ... - body ...))))))])) + (map add-context (syntax->list #'(body ...)))] + [DEF def-id]) + (with-syntax ([(top-decl ...) + (if (and need-top-decl? (equal? 'top-level (syntax-local-context))) + #'((define-syntaxes (id ... ...) (values))) + null)]) + #'(begin + top-decl ... + (DEF (id ...) expr) + ... + body ...)))))))])) (define-syntax (splicing-let-syntax stx) - (do-let-syntax stx #f #f #'let-syntax)) + (do-let-syntax stx #f #f #'let-syntax #'define-syntaxes #f)) (define-syntax (splicing-let-syntaxes stx) - (do-let-syntax stx #f #t #'let-syntaxes)) + (do-let-syntax stx #f #t #'let-syntaxes #'define-syntaxes #f)) (define-syntax (splicing-letrec-syntax stx) - (do-let-syntax stx #t #f #'letrec-syntax)) + (do-let-syntax stx #t #f #'letrec-syntax #'define-syntaxes #f)) (define-syntax (splicing-letrec-syntaxes stx) - (do-let-syntax stx #t #t #'letrec-syntaxes)) + (do-let-syntax stx #t #t #'letrec-syntaxes #'define-syntaxes #f)) + +(define-syntax (splicing-let stx) + (do-let-syntax stx #f #f #'let #'define-values #f)) + +(define-syntax (splicing-let-values stx) + (do-let-syntax stx #f #t #'let-values #'define-values #f)) + +(define-syntax (splicing-letrec stx) + (do-let-syntax stx #t #f #'letrec #'define-values #t)) + +(define-syntax (splicing-letrec-values stx) + (do-let-syntax stx #t #t #'letrec-values #'define-values #t)) + +;; ---------------------------------------- + +(define-syntax (splicing-letrec-syntaxes+values stx) + (syntax-case stx () + [(_ ([sids sexpr] ...) ([vids vexpr] ...) body ...) + (let* ([all-sids (map (check-ids stx) + (syntax->list #'(sids ...)))] + [all-vids (map (check-ids stx) + (syntax->list #'(vids ...)))] + [all-ids (append all-sids all-vids)]) + (check-dup-binding stx all-ids) + (if (eq? 'expression (syntax-local-context)) + (syntax/loc stx + (letrec-syntaxes+values ([sids sexpr] ...) ([vids vexpr] ...) + (#%expression body) ...)) + (let ([def-ctx (syntax-local-make-definition-context)] + [ctx (list (gensym 'intdef))]) + (syntax-local-bind-syntaxes (apply append all-ids) #f def-ctx) + (internal-definition-context-seal def-ctx) + (let* ([add-context + (lambda (expr) + (let ([q (local-expand #`(quote #,expr) + ctx + (list #'quote) + def-ctx)]) + (syntax-case q () + [(_ expr) #'expr])))] + [add-context-to-idss + (lambda (idss) + (map add-context idss))]) + (with-syntax ([((sid ...) ...) + (map add-context-to-idss all-sids)] + [((vid ...) ...) + (map add-context-to-idss all-vids)] + [(sexpr ...) + (map add-context (syntax->list #'(sexpr ...)))] + [(vexpr ...) + (map add-context (syntax->list #'(vexpr ...)))] + [(body ...) + (map add-context (syntax->list #'(body ...)))]) + (with-syntax ([top-decl + (if (equal? 'top-level (syntax-local-context)) + #'(define-syntaxes (vid ... ...) (values)) + #'(begin))]) + (syntax/loc stx + (begin + top-decl + (define-syntaxes (sid ...) sexpr) ... + (define-values (vid ...) vexpr) ... + body ...))))))))])) + + + +(define-syntax (splicing-local stx) + (do-local stx #'splicing-letrec-syntaxes+values)) ;; ---------------------------------------- diff --git a/collects/scribble/eval.ss b/collects/scribble/eval.ss index 269dc707b0..93eb5a2c46 100644 --- a/collects/scribble/eval.ss +++ b/collects/scribble/eval.ss @@ -238,7 +238,8 @@ (call-with-trusted-sandbox-configuration (lambda () (parameterize ([sandbox-output 'string] - [sandbox-error-output 'string]) + [sandbox-error-output 'string] + [sandbox-propagate-breaks #f]) (make-evaluator '(begin (require scheme/base))))))) (define (close-eval e) @@ -246,23 +247,24 @@ "") (define (do-plain-eval ev s catching-exns?) - (call-with-values (lambda () - ((scribble-eval-handler) - ev - catching-exns? - (let ([s (strip-comments s)]) - (cond - [(syntax? s) - (syntax-case s (module) - [(module . _rest) - (syntax->datum s)] - [_else s])] - [(bytes? s) - `(begin ,s)] - [(string? s) - `(begin ,s)] - [else s])))) - list)) + (parameterize ([sandbox-propagate-breaks #f]) + (call-with-values (lambda () + ((scribble-eval-handler) + ev + catching-exns? + (let ([s (strip-comments s)]) + (cond + [(syntax? s) + (syntax-case s (module) + [(module . _rest) + (syntax->datum s)] + [_else s])] + [(bytes? s) + `(begin ,s)] + [(string? s) + `(begin ,s)] + [else s])))) + list))) (define-syntax-rule (quote-expr e) 'e) diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss index d2d904f59f..8888b06062 100644 --- a/collects/scribble/html-render.ss +++ b/collects/scribble/html-render.ss @@ -1076,6 +1076,7 @@ [(#f) null] [(top) '((valign "top"))] [(baseline) '((valign "baseline"))] + [(center) '((valign "center"))] [(bottom) '((valign "bottom"))]) ,@(if (string? st) `([class ,st]) diff --git a/collects/scribble/latex-render.ss b/collects/scribble/latex-render.ss index 4399ddd8e4..4633c9d590 100644 --- a/collects/scribble/latex-render.ss +++ b/collects/scribble/latex-render.ss @@ -302,12 +302,12 @@ (let ([flows (car flowss)] [row-style (car row-styles)]) (let loop ([flows flows] - [col-v-styles (and (list? row-style) - (or (let ([p (assoc 'valignment row-style)]) - (and p (cdr p))) - (let ([p (and (list? (table-style t)) - (assoc 'valignment (table-style t)))]) - (and p (cdr p)))))]) + [col-v-styles (or (and (list? row-style) + (let ([p (assoc 'valignment row-style)]) + (and p (cdr p)))) + (let ([p (and (list? (table-style t)) + (assoc 'valignment (table-style t)))]) + (and p (cdr p))))]) (unless (null? flows) (when index? (printf "\\item ")) (unless (eq? 'cont (car flows)) @@ -347,17 +347,20 @@ (printf "\\begin{tabular}~a{@{}l@{}}\n" (cond [(eq? vstyle 'top) "[t]"] + [(eq? vstyle 'center) "[c]"] [else ""]))) (let loop ([ps (flow-paragraphs p)]) (cond [(null? ps) (void)] [else - (let ([minipage? (not (or (paragraph? (car ps)) - (table? (car ps))))]) + (let ([minipage? (or (not (or (paragraph? (car ps)) + (table? (car ps)))) + (eq? vstyle 'center))]) (when minipage? (printf "\\begin{minipage}~a{~a\\linewidth}\n" (cond [(eq? vstyle 'top) "[t]"] + [(eq? vstyle 'center) "[c]"] [else ""]) (/ 1.0 twidth))) (render-block (car ps) part ri #f) diff --git a/collects/scribble/private/manual-form.ss b/collects/scribble/private/manual-form.ss index 1302b65d5a..7f032455b0 100644 --- a/collects/scribble/private/manual-form.ss +++ b/collects/scribble/private/manual-form.ss @@ -106,6 +106,9 @@ [(_ #:literals lits [spec ...] desc ...) (syntax/loc stx (defform*/subs #:literals lits [spec ...] () desc ...))] + [(_ #:id id [spec ...] desc ...) + (syntax/loc stx + (defform*/subs #:id id [spec ...] () desc ...))] [(_ [spec ...] desc ...) (syntax/loc stx (defform*/subs [spec ...] () desc ...))])) diff --git a/collects/scribble/scheme.ss b/collects/scribble/scheme.ss index 281603a8bc..3518e4c548 100644 --- a/collects/scribble/scheme.ss +++ b/collects/scribble/scheme.ss @@ -123,7 +123,8 @@ (make-element style content))) (define (typeset-atom c out color? quote-depth) - (if (var-id? (syntax-e c)) + (if (and (var-id? (syntax-e c)) + (zero? quote-depth)) (out (format "~s" (let ([v (var-id-sym (syntax-e c))]) (if (syntax? v) (syntax-e v) @@ -135,7 +136,9 @@ (let ([sc (syntax-e c)]) (let ([s (format "~s" (if (literal-syntax? sc) (literal-syntax-stx sc) - sc))]) + (if (var-id? sc) + (var-id-sym sc) + sc)))]) (if (and (symbol? sc) ((string-length s) . > . 1) (char=? (string-ref s 0) #\_) diff --git a/collects/scribble/text/output.ss b/collects/scribble/text/output.ss index f0e5e80dd0..238b25b4f6 100644 --- a/collects/scribble/text/output.ss +++ b/collects/scribble/text/output.ss @@ -2,7 +2,7 @@ (require scheme/promise) -(provide output splice verbatim unverbatim flush prefix) +(provide output) ;; Outputs some value, for the preprocessor langauge. ;; @@ -19,9 +19,11 @@ ;; system (when line counts are enabled) -- this is used to tell what part of a ;; prefix is already displayed. ;; -;; Each prefix is either an integer (for a number of spaces), a string, or #f -;; indicating that prefixes are disabled (different from 0 -- they will not be -;; accumulated). +;; Each prefix is either an integer (for a number of spaces) or a +;; string. The prefix mechanism can be disabled by using #f for the +;; global prefix, and in this case the line prefix can have (cons pfx +;; lpfx) so it can be restored -- used by `verbatim' and `unverbatim' +;; resp. (This is different from 0 -- no prefix will be accumulated). ;; (define (output x [p (current-output-port)]) ;; these are the global prefix and the one that is local to the current line @@ -63,6 +65,37 @@ (let ([col (- col len1)] [len2 (if (number? pfx2) pfx2 (string-length pfx2))]) (when (< col len2) (write-string (->str pfx2) p col )))]))))) + ;; the basic printing unit: strings + (define (output-string x) + (define pfx (mcar pfxs)) + (if (not pfx) ; verbatim mode? + (write-string x p) + (let ([len (string-length x)] + [nls (regexp-match-positions* #rx"\n" x)]) + (let loop ([start 0] [nls nls] [lpfx (mcdr pfxs)] [col (getcol)]) + (cond [(pair? nls) + (let ([nl (car nls)]) + (if (regexp-match? #rx"^ *$" x start (car nl)) + (newline p) ; only spaces before the end of the line + (begin (output-pfx col pfx lpfx) + (write-string x p start (cdr nl)))) + (loop (cdr nl) (cdr nls) 0 0))] + ;; last substring from here (always set lpfx state when done) + [(start . = . len) + (set-mcdr! pfxs lpfx)] + [(col . > . (2pfx-length pfx lpfx)) + (set-mcdr! pfxs lpfx) + ;; the prefix was already shown, no accumulation needed + (write-string x p start)] + [else + (let ([m (regexp-match-positions #rx"^ +" x start)]) + ;; accumulate spaces to lpfx, display if it's not all spaces + (let ([lpfx (if m (pfx+ lpfx (- (cdar m) (caar m))) lpfx)]) + (set-mcdr! pfxs lpfx) + (unless (and m (= len (cdar m))) + (output-pfx col pfx lpfx) + ;; the spaces were already added to lpfx + (write-string x p (if m (cdar m) start)))))]))))) ;; main loop (define (loop x) (cond @@ -72,16 +105,13 @@ ;; one, then output the contents recursively (no need to change the ;; state, since we pass the values in the loop, and we'd need to restore ;; it afterwards anyway) - [(pair? x) (let* ([pfx (mcar pfxs)] [lpfx (mcdr pfxs)] - [npfx (pfx+col (pfx+ pfx lpfx))]) - (set-mcar! pfxs npfx) (set-mcdr! pfxs 0) - (if (list? x) + [(pair? x) (if (list? x) + (let* ([pfx (mcar pfxs)] [lpfx (mcdr pfxs)] + [npfx (pfx+col (pfx+ pfx lpfx))]) + (set-mcar! pfxs npfx) (set-mcdr! pfxs 0) (for ([x (in-list x)]) (loop x)) - (let ploop ([x x]) - (if (pair? x) - (begin (loop (car x)) (ploop (cdr x))) - (loop x)))) - (set-mcar! pfxs pfx) (set-mcdr! pfxs lpfx))] + (set-mcar! pfxs pfx) (set-mcdr! pfxs lpfx)) + (begin (loop (car x)) (loop (cdr x))))] ;; delayed values [(and (procedure? x) (procedure-arity-includes? x 0)) (loop (x))] [(promise? x) (loop (force x))] @@ -114,41 +144,16 @@ [else (error 'output "unknown special value flag: ~e" (special-flag x))]))] [else - (let* ([x (cond [(string? x) x] - [(bytes? x) (bytes->string/utf-8 x)] - [(symbol? x) (symbol->string x)] - [(path? x) (path->string x)] - [(keyword? x) (keyword->string x)] - [(number? x) (number->string x)] - [(char? x) (string x)] - ;; generic fallback: throw an error - [else (error 'output "don't know how to render value: ~v" - x)])] - [len (string-length x)] - [nls (regexp-match-positions* #rx"\n" x)] - [pfx (mcar pfxs)]) - (let loop ([start 0] [nls nls] [lpfx (mcdr pfxs)] [col (getcol)]) - (cond [(pair? nls) - (let ([nl (car nls)]) - (output-pfx col pfx lpfx) - (write-string x p start (cdr nl)) - (loop (cdr nl) (cdr nls) 0 0))] - ;; last substring from here (always set lpfx state when done) - [(start . = . len) - (set-mcdr! pfxs lpfx)] - [(col . > . (2pfx-length pfx lpfx)) - (set-mcdr! pfxs lpfx) - ;; the prefix was already shown, no accumulation needed - (write-string x p start)] - [else - (let ([m (regexp-match-positions #rx"^ +" x start)]) - ;; accumulate spaces to lpfx, display if it's not all spaces - (let ([lpfx (if m (pfx+ lpfx (- (cdar m) (caar m))) lpfx)]) - (set-mcdr! pfxs lpfx) - (unless (and m (= len (cdar m))) - (output-pfx col pfx lpfx) - ;; the spaces were already added to lpfx - (write-string x p (if m (cdar m) start)))))])))])) + (output-string + (cond [(string? x) x] + [(bytes? x) (bytes->string/utf-8 x)] + [(symbol? x) (symbol->string x)] + [(path? x) (path->string x)] + [(keyword? x) (keyword->string x)] + [(number? x) (number->string x)] + [(char? x) (string x)] + ;; generic fallback: throw an error + [else (error 'output "don't know how to render value: ~v" x)]))])) ;; (port-count-lines! p) (loop x) @@ -164,6 +169,10 @@ (set! last (cons p s)) s))))) +;; special constructs + +(provide splice verbatim unverbatim flush prefix) + (define-struct special (flag contents)) (define (splice . contents) (make-special 'splice contents)) @@ -179,3 +188,25 @@ (let ([spaces (make-string n #\space)]) (if (< n 80) (vector-set! v n spaces) (hash-set! t n spaces)) spaces))))) + +;; Convenient utilities + +(provide add-newlines) +(define (add-newlines list #:sep [sep "\n"]) + (define r + (let loop ([list list]) + (if (null? list) + null + (let ([1st (car list)]) + (if (or (not 1st) (void? 1st)) + (loop (cdr list)) + (list* sep 1st (loop (cdr list)))))))) + (if (null? r) r (cdr r))) + +(provide split-lines) +(define (split-lines list) + (let loop ([list list] [cur '()] [r '()]) + (cond + [(null? list) (reverse (cons (reverse cur) r))] + [(equal? "\n" (car list)) (loop (cdr list) '() (cons (reverse cur) r))] + [else (loop (cdr list) (cons (car list) cur) r)]))) diff --git a/collects/scribble/text/syntax-utils.ss b/collects/scribble/text/syntax-utils.ss index 2c181e4efa..5ec450eb5c 100644 --- a/collects/scribble/text/syntax-utils.ss +++ b/collects/scribble/text/syntax-utils.ss @@ -159,8 +159,10 @@ (cond [(pair? rest) #`(list* #,@nondefns (begin/collect* #t #,@rest))] [(and (not always-list?) (= 1 (length nondefns))) (car nondefns)] [else #`(list #,@nondefns)])) - (local-expand (if (null? defns) body #`(let () #,@defns #,body)) - context stoplist (car context))) + (begin0 + (local-expand (if (null? defns) body #`(let () #,@defns #,body)) + context stoplist (car context)) + (internal-definition-context-seal (car context)))) (define-syntax-rule (begin/collect x ...) (begin/collect* #f x ...)) ;; begin for templates (allowing definition blocks) diff --git a/collects/scribblings/drscheme/keybindings.scrbl b/collects/scribblings/drscheme/keybindings.scrbl index 21bdee0c6a..42b6238335 100644 --- a/collects/scribblings/drscheme/keybindings.scrbl +++ b/collects/scribblings/drscheme/keybindings.scrbl @@ -1,10 +1,15 @@ #lang scribble/doc @(require "common.ss" + scribble/struct scribble/bnf + scheme/list + mrlib/tex-table (for-label scheme/gui/base)) @(define (keybinding key . desc) - (apply item @index[(list (format "~a keybinding" key)) key] " : " desc)) + (let* ([keys (if (string? key) (list key) key)] + [key-str (apply string-append (add-between keys " "))]) + (apply item @index[(map (lambda (x) (format "~a keybinding" x)) keys) key-str] " : " desc))) @(define-syntax-rule (def-mod-beg id) (begin @@ -166,6 +171,25 @@ as the @tech{definitions window} plus a few more: expression history down to the prompt} ] +@section{LaTeX and TeX inspired keybindings} + +@itemize[ +@keybinding['("C-\\" "M-\\")]{traces backwards from the insertion +point, looking for a backslash followed by a @index["LaTeX"]{LaTeX} macro name; if one is +found, it replaces the backslash and the macro's name with the keybinding. +These are the currently supported macro names and the keys they map into: +@(make-table + '() + (map (lambda (line) + (let ([macro (list-ref line 0)] + [char (list-ref line 1)]) + (list (make-flow (list (make-paragraph (list (index (format "\\~a keyboard shortcut" macro)) + (tt (format "\\~a" macro)))))) + (make-flow (list (make-paragraph (list char))))))) + tex-shortcut-table)) +} +] + @section[#:tag "defining-shortcuts"]{Defining Custom Shortcuts} The @onscreen{Add User-defined Keybindings...} menu item in the diff --git a/collects/scribblings/foreign/derived.scrbl b/collects/scribblings/foreign/derived.scrbl index 2b64510041..8ff776dd5a 100644 --- a/collects/scribblings/foreign/derived.scrbl +++ b/collects/scribblings/foreign/derived.scrbl @@ -64,8 +64,6 @@ obtain a tag. The tag is the string form of @schemevarfont{id}.} @subsection{Unsafe Tagged C Pointer Functions} -@declare-exporting[scribblings/foreign/unsafe-foreign] - @defproc*[([(cpointer-has-tag? [cptr any/c] [tag any/c]) boolean?] [(cpointer-push-tag! [cptr any/c] [tag any/c]) void])]{ @@ -157,8 +155,6 @@ Converts the list @scheme[lst] to a C vector of the given @subsection{Unsafe C Vector Construction} -@declare-exporting[scribblings/foreign/unsafe-foreign] - @defproc[(make-cvector* [cptr any/c] [type ctype?] [length exact-nonnegative-integer?]) cvector?]{ diff --git a/collects/scribblings/foreign/foreign.scrbl b/collects/scribblings/foreign/foreign.scrbl index 880e267b93..bdc92ff4d8 100644 --- a/collects/scribblings/foreign/foreign.scrbl +++ b/collects/scribblings/foreign/foreign.scrbl @@ -5,7 +5,7 @@ @author["Eli Barzilay"] -@defmodule[scheme/foreign] +@defmodule[scheme/foreign #:use-sources ('#%foreign)] The @schememodname[scheme/foreign] library enables the direct use of C-based APIs within Scheme programs---without writing any new C diff --git a/collects/scribblings/foreign/libs.scrbl b/collects/scribblings/foreign/libs.scrbl index cd3c352a56..d514f24f29 100644 --- a/collects/scribblings/foreign/libs.scrbl +++ b/collects/scribblings/foreign/libs.scrbl @@ -19,9 +19,6 @@ Returns @scheme[#t] if @scheme[v] is the result of @scheme[ffi-lib], @section{Unsafe Library Functions} -@declare-exporting[scribblings/foreign/unsafe-foreign] - - @defproc[(ffi-lib [path (or/c path-string? #f)] [version (or/c string? (listof string?) #f) #f]) any]{ diff --git a/collects/scribblings/foreign/misc.scrbl b/collects/scribblings/foreign/misc.scrbl index cf5dd3d4f2..850e89b714 100644 --- a/collects/scribblings/foreign/misc.scrbl +++ b/collects/scribblings/foreign/misc.scrbl @@ -54,8 +54,6 @@ Like @scheme[list->cblock], but for Scheme vectors.} @section{Unsafe Miscellaneous Operations} -@declare-exporting[scribblings/foreign/unsafe-foreign] - @defproc[(cblock->list [cblock any/c][type ctype?][length exact-nonnegative-integer?]) list?]{ diff --git a/collects/scribblings/foreign/pointers.scrbl b/collects/scribblings/foreign/pointers.scrbl index 9f4a4a47e1..5810e194a6 100644 --- a/collects/scribblings/foreign/pointers.scrbl +++ b/collects/scribblings/foreign/pointers.scrbl @@ -50,8 +50,6 @@ offset is always in bytes.} @section{Unsafe Pointer Operations} -@declare-exporting[scribblings/foreign/unsafe-foreign] - @defproc[(set-ptr-offset! [cptr cpointer?][offset exact-integer?][ctype ctype? _byte]) void?]{ @@ -209,8 +207,6 @@ can contain other information).} @section{Unsafe Memory Management} -@declare-exporting[scribblings/foreign/unsafe-foreign] - For general information on C-level memory management with PLT Scheme, see @|InsideMzScheme|. diff --git a/collects/scribblings/foreign/unsafe-foreign.ss b/collects/scribblings/foreign/unsafe-foreign.ss index 766bbdc086..e3eccbb4a8 100644 --- a/collects/scribblings/foreign/unsafe-foreign.ss +++ b/collects/scribblings/foreign/unsafe-foreign.ss @@ -1,11 +1,31 @@ #lang scheme/base - -(require scheme/foreign) +(require scheme/foreign + (for-syntax scheme/base + scheme/provide-transform)) (error 'unsafe! "only `for-label' use in the documentation") (unsafe!) -(provide (protect-out (all-defined-out)) +;; This is like `all-defined-out', but it ignores the 'not-provide-all-defined +;; property, so that the bindings introduced by `unsafe!' are exported. +(define-syntax all-unsafe-defined-out + (make-provide-transformer + (lambda (stx modes) + (syntax-case stx () + [(_) + (let-values ([(ids stx-ids) (syntax-local-module-defined-identifiers)] + [(same-ctx?) (lambda (free-identifier=?) + (lambda (id) + (free-identifier=? id + (datum->syntax + stx + (syntax-e id)))))]) + (map (lambda (id) + (make-export id (syntax-e id) 0 #f stx)) + (filter (same-ctx? free-identifier=?) + ids)))])))) + +(provide (protect-out (all-unsafe-defined-out)) (all-from-out scheme/foreign)) diff --git a/collects/scribblings/guide/module-basics.scrbl b/collects/scribblings/guide/module-basics.scrbl index ac6f8fa0a2..bfe8ff2180 100644 --- a/collects/scribblings/guide/module-basics.scrbl +++ b/collects/scribblings/guide/module-basics.scrbl @@ -67,7 +67,7 @@ scheme In addition to the main @tech{collection} directory, which contains all collections that are part of the installation, collections can also be installed in a user-specific location. Finally, additional -collection directories can be specified n configuration files or +collection directories can be specified in configuration files or through the @envvar{PLTCOLLECTS} search path. Try running the following program to find out where your collections are: diff --git a/collects/scribblings/mzc/cc.scrbl b/collects/scribblings/mzc/cc.scrbl index cc5e7d2b03..6e9c005a89 100644 --- a/collects/scribblings/mzc/cc.scrbl +++ b/collects/scribblings/mzc/cc.scrbl @@ -1,6 +1,8 @@ #lang scribble/doc @(require scribble/manual - (for-label scheme/base) + (for-label scheme/base + compiler/xform + dynext/compile) "common.ss") @(define (xflag str) (as-index (DFlag str))) @@ -55,3 +57,29 @@ loaded into the 3m variant of PLT Scheme. The @as-index{@DFlag{cgc}} flag specifies that the extension is to be used with the CGC. The default depends on @|mzc|: @DFlag{3m} if @|mzc| itself is running in 3m, @DFlag{cgc} if @|mzc| itself is running in CGC. + + +@section[#:tag "xform-api"]{Scheme API for 3m Transformation} + +@defmodule[compiler/xform] + +@defproc[(xform [quiet? any/c] + [input-file path-string?] + [output-file path-string?] + [include-dirs (listof path-string?)] + [#:keep-lines? keep-lines? boolean? #f]) + any/c]{ + +Transforms C code that is written without explicit GC-cooperation +hooks to cooperate with PLT Scheme's 3m garbage collector; see +@secref[#:doc '(lib "scribblings/inside/inside.scrbl") "overview"] in +@other-manual['(lib "scribblings/inside/inside.scrbl")]. + +The arguments are as for @scheme[compile-extension]; in addition +@scheme[keep-lines?] can be @scheme[#t] to generate GCC-style +annotations to connect the generated C code with the original source +locations. + +The file generated by @scheme[xform] can be compiled via +@scheme[compile-extension].} + diff --git a/collects/scribblings/reference/cont-marks.scrbl b/collects/scribblings/reference/cont-marks.scrbl index 54b2cdb18d..e847bd67b1 100644 --- a/collects/scribblings/reference/cont-marks.scrbl +++ b/collects/scribblings/reference/cont-marks.scrbl @@ -89,7 +89,7 @@ separated by a prompt tagged with @scheme[prompt-tag]..} @defproc[(continuation-mark-set->list* [mark-set continuation-mark-set?] - [key-v any/c] + [key-list (listof any/c)] [none-v any/c #f] [prompt-tag prompt-tag? (default-continuation-prompt-tag)]) (listof vector?)]{ diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index f8df8bd61d..b35a8f56cb 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -367,7 +367,7 @@ The @scheme[case->] contract is a specialized contract, designed to match @scheme[case-lambda] and @scheme[unconstrained-domain->] allows range checking without requiring that the domain have any particular shape -(see below for an exmaple use). +(see below for an example use). @defform*/subs[#:literals (any values) [(-> dom ... range)] diff --git a/collects/scribblings/reference/file-ports.scrbl b/collects/scribblings/reference/file-ports.scrbl index f5261aba5e..037c6f285e 100644 --- a/collects/scribblings/reference/file-ports.scrbl +++ b/collects/scribblings/reference/file-ports.scrbl @@ -111,7 +111,8 @@ files that already exist: @item{@indexed-scheme['update] --- open an existing file without truncating it; if the file does not exist, the - @exnraise[exn:fail:filesystem].} + @exnraise[exn:fail:filesystem]. Use @scheme[file-position] + to change the current read/write position.} @item{@indexed-scheme['can-update] --- open an existing file without truncating it, or create the file if it does not exist.} diff --git a/collects/scribblings/reference/module-reflect.scrbl b/collects/scribblings/reference/module-reflect.scrbl index 801383101e..91d47f3ae9 100644 --- a/collects/scribblings/reference/module-reflect.scrbl +++ b/collects/scribblings/reference/module-reflect.scrbl @@ -256,7 +256,9 @@ the module's explicit imports.} Returns two association lists mapping @tech{phase level} values (where @scheme[#f] corresponds to the @tech{label phase level}) to exports at the corresponding phase. The first association list is for exported -variables, and the second is for exported syntax. +variables, and the second is for exported syntax. Beware however, that +value bindings re-exported though a @tech{rename transformer} are in +the syntax list instead of the value list. Each associated list, which is represented by @scheme[list?] in the result contracts above, more precisely matches the contract diff --git a/collects/scribblings/reference/numbers.scrbl b/collects/scribblings/reference/numbers.scrbl index 01a0de3cea..900e15ee55 100644 --- a/collects/scribblings/reference/numbers.scrbl +++ b/collects/scribblings/reference/numbers.scrbl @@ -890,6 +890,10 @@ Returns the hyperbolic sine of @scheme[z].} Returns the hyperbolic cosine of @scheme[z].} +@defproc[(tanh [z number?]) number?]{ + +Returns the hyperbolic tangent of @scheme[z].} + @; ---------------------------------------------------------------------- @close-eval[math-eval] diff --git a/collects/scribblings/reference/pairs.scrbl b/collects/scribblings/reference/pairs.scrbl index bda29a70ea..81e09663ae 100644 --- a/collects/scribblings/reference/pairs.scrbl +++ b/collects/scribblings/reference/pairs.scrbl @@ -633,6 +633,13 @@ Returns @scheme[(filter (lambda (x) x) (map proc lst ...))], but without building the intermediate list.} +@defproc[(count [proc procedure?] [lst list?] ...+) + list?]{ + +Returns @scheme[(length (filter proc lst ...))], but +without building the intermediate list.} + + @defproc[(partition [pred procedure?] [lst list?]) (values list? list?)]{ diff --git a/collects/scribblings/reference/sandbox.scrbl b/collects/scribblings/reference/sandbox.scrbl index 386a62df8d..d469fb5f94 100644 --- a/collects/scribblings/reference/sandbox.scrbl +++ b/collects/scribblings/reference/sandbox.scrbl @@ -411,12 +411,18 @@ collected by sandbox evaluators. Use @defboolparam[sandbox-propagate-breaks propagate?]{ -When this boolean parameter is true, breaking while an evaluator is -running evaluator propagates the break signal to the sandboxed +When both this boolean parameter and @scheme[(break-enabled)] are true, +breaking while an evaluator is +running propagates the break signal to the sandboxed context. This makes the sandboxed evaluator break, typically, but beware that sandboxed evaluation can capture and avoid the breaks (so if safe execution of code is your goal, make sure you use it with a -time limit). The default is @scheme[#t].} +time limit). Also, beware that a break may be received after the +evaluator's result, in which case the evaluation result is lost. Finally, +beware that a break may be propagated after an evaluator has produced +a result, so that the break is visible on the next interaction with +the evaluator (or the break is lost if the evaluator is not used +further). The default is @scheme[#t].} @defparam[sandbox-namespace-specs spec (cons/c (-> namespace?) diff --git a/collects/scribblings/reference/sequences.scrbl b/collects/scribblings/reference/sequences.scrbl index c19a10da47..cee6ed893a 100644 --- a/collects/scribblings/reference/sequences.scrbl +++ b/collects/scribblings/reference/sequences.scrbl @@ -1,6 +1,7 @@ #lang scribble/doc @(require "mz.ss" - (for-syntax scheme/base)) + (for-syntax scheme/base) + scribble/scheme) @(define-syntax speed (syntax-rules () @@ -246,23 +247,24 @@ the structure and returns a sequence. If @scheme[v] is an instance of a structure type with this property, then @scheme[(sequence? v)] produces @scheme[#t]. -@examples[ -(define-struct train (car next) - #:property prop:sequence (lambda (t) - (make-do-sequence - (lambda () - (values train-car - train-next - t - (lambda (t) t) - (lambda (v) #t) - (lambda (t v) #t)))))) -(for/list ([c (make-train 'engine - (make-train 'boxcar - (make-train 'caboose - #f)))]) - c) -]} +@let-syntax[([car (make-element-id-transformer (lambda (id) #'@schemeidfont{car}))]) + @examples[ + (define-struct train (car next) + #:property prop:sequence (lambda (t) + (make-do-sequence + (lambda () + (values train-car + train-next + t + (lambda (t) t) + (lambda (v) #t) + (lambda (t v) #t)))))) + (for/list ([c (make-train 'engine + (make-train 'boxcar + (make-train 'caboose + #f)))]) + c) + ]]} @section{Sequence Generators} diff --git a/collects/scribblings/reference/splicing.scrbl b/collects/scribblings/reference/splicing.scrbl index 634458661c..ccae290e4f 100644 --- a/collects/scribblings/reference/splicing.scrbl +++ b/collects/scribblings/reference/splicing.scrbl @@ -1,7 +1,8 @@ #lang scribble/doc @(require "mz.ss" (for-label scheme/splicing - scheme/stxparam)) + scheme/stxparam + scheme/local)) @(define splice-eval (make-base-eval)) @interaction-eval[#:eval splice-eval (require scheme/splicing @@ -13,16 +14,24 @@ @note-lib-only[scheme/splicing] @deftogether[( +@defidform[splicing-let] +@defidform[splicing-letrec] +@defidform[splicing-let-values] +@defidform[splicing-letrec-values] @defidform[splicing-let-syntax] @defidform[splicing-letrec-syntax] @defidform[splicing-let-syntaxes] @defidform[splicing-letrec-syntaxes] +@defidform[splicing-letrec-syntaxes+values] +@defidform[splicing-local] )]{ -Like @scheme[let-syntax], @scheme[letrec-syntax], -@scheme[let-syntaxes], and @scheme[letrec-syntaxes], except that in a +Like @scheme[let], @scheme[letrec], @scheme[let-values], +@scheme[letrec-values], @scheme[let-syntax], @scheme[letrec-syntax], +@scheme[let-syntaxes], @scheme[letrec-syntaxes], +@scheme[letrec-syntaxes+values], and @scheme[local], except that in a definition context, the body forms are spliced into the enclosing -definition context (in the same as as for @scheme[begin]). +definition context (in the same way as for @scheme[begin]). @examples[ #:eval splice-eval @@ -30,7 +39,23 @@ definition context (in the same as as for @scheme[begin]). (define o one)) o one -]} +] + +When a splicing binding form occurs in a @tech{top-level context} or +@tech{module context}, its local bindings are treated similarly to +definitions. In particular, if a reference to one of the splicing +form's bound variables is evaluated before the variable is +initialized, an unbound variable error is raised, instead of the +variable evaluating to the undefined value. Also, syntax bindings are +evaluated every time the module is @tech{visit}ed, instead of only +once during compilation as in @scheme[let-syntax], etc. + +@examples[ +#:eval splice-eval +(splicing-letrec ([x bad] + [bad 1]) + x)] +} @defidform[splicing-syntax-parameterize]{ diff --git a/collects/scribblings/reference/stx-comp.scrbl b/collects/scribblings/reference/stx-comp.scrbl index bdcacc0ba9..8bcda845b5 100644 --- a/collects/scribblings/reference/stx-comp.scrbl +++ b/collects/scribblings/reference/stx-comp.scrbl @@ -22,15 +22,16 @@ suitable expression context at the @tech{phase level} indicated by Returns @scheme[#t] if @scheme[a-id] and @scheme[b-id] access the same @tech{local binding}, @tech{module binding}, or @tech{top-level -binding} at the @tech{phase level} indicated by -@scheme[phase-level]. A @scheme[#f] value for @scheme[phase-level] -corresponds to the @tech{label phase level}. +binding}---perhaps via @tech{rename transformers}---at the @tech{phase +level} indicated by @scheme[phase-level]. A @scheme[#f] value for +@scheme[phase-level] corresponds to the @tech{label phase level}. ``Same module binding'' means that the identifiers refer to the same -original definition site, not necessarily the @scheme[require] or -@scheme[provide] site. Due to renaming in @scheme[require] and -@scheme[provide], the identifiers may return distinct results with -@scheme[syntax-e].} +original definition site, and not necessarily to the same +@scheme[require] or @scheme[provide] site. Due to renaming in +@scheme[require] and @scheme[provide], or due to a transformer binding +to a @tech{rename transformer}, the identifiers may return distinct +results with @scheme[syntax-e].} @defproc[(free-transformer-identifier=? [a-id syntax?][b-id syntax?]) boolean?]{ @@ -132,7 +133,13 @@ Returns one of three kinds of values, depending on the binding of @tech{top-level binding} (or, equivalently, if it is @tech{unbound}).} - }} + } + +If @scheme[id-stx] is bound to a @tech{rename-transformer}, the result +from @scheme[identifier] binding is for the identifier in the +transformer, so that @scheme[identifier-binding] is consistent with +@scheme[free-identifier=?].} + @defproc[(identifier-transformer-binding [id-stx syntax?]) (or/c 'lexical diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl index fac8180a96..b1aa58f3a2 100644 --- a/collects/scribblings/reference/stx-trans.scrbl +++ b/collects/scribblings/reference/stx-trans.scrbl @@ -16,15 +16,22 @@ expander, otherwise the @exnraise[exn:fail:contract].}) @title[#:tag "stxtrans"]{Syntax Transformers} +@defproc[(set!-transformer? [v any/c]) boolean?]{ + +Returns @scheme[#t] if @scheme[v] is a value created by +@scheme[make-set!-transformer] or an instance of a structure type with +the @scheme[prop:set!-transformer] property, @scheme[#f] otherwise.} + + @defproc[(make-set!-transformer [proc (syntax? . -> . syntax?)]) set!-transformer?]{ -Creates a @tech{syntax transformer} that cooperates with +Creates an @tech{assignment transformer} that cooperates with @scheme[set!]. If the result of @scheme[make-set!-transformer] is -bound to @scheme[identifier] as a @tech{transformer binding}, then -@scheme[proc] is applied as a transformer when @scheme[identifier] is +bound to @scheme[_id] as a @tech{transformer binding}, then +@scheme[proc] is applied as a transformer when @scheme[_id] is used in an expression position, or when it is used as the target of a -@scheme[set!] assignment as @scheme[(set! identifier _expr)]. When the +@scheme[set!] assignment as @scheme[(set! _id _expr)]. When the identifier appears as a @scheme[set!] target, the entire @scheme[set!] expression is provided to the transformer. @@ -45,17 +52,48 @@ expression is provided to the transformer. ]} -@defproc[(set!-transformer? [v any/c]) boolean?]{ - -Returns @scheme[#t] if @scheme[v] is a value created by -@scheme[make-set!-transformer], @scheme[#f] otherwise.} - - @defproc[(set!-transformer-procedure [transformer set!-transformer?]) (syntax? . -> . syntax?)]{ Returns the procedure that was passed to -@scheme[make-set!-transformer] to create @scheme[transformer].} +@scheme[make-set!-transformer] to create @scheme[transformer] or that +is identified by the @scheme[prop:set!-transformer] property of +@scheme[transformer].} + + +@defthing[prop:set!-transformer struct-type-property?]{ + +A @tech{structure type property} to indentify structure types that act +as @tech{assignment transformers} like the ones created by +@scheme[make-set!-transformer]. + +The property value must be an exact integer or procedure of one +argument. In the former case, the integer designates a field within +the structure that should contain a procedure; the integer must be +between @scheme[0] (inclusive) and the number of non-automatic fields +in the structure type (exclusive, not counting supertype fields), and +the designated field must also be specified as immutable. + +If the property value is an procedure, then the procedure serves as a +@tech{syntax transformer} and for @scheme[set!] transformations. If +the property value is an integer, the target identifier is extracted +from the structure instance; if the field value is not a procedure of +one argument, then a procedure that always calls +@scheme[raise-syntax-error] is used, instead. + +If a value has both the @scheme[prop:set!-transformer] and +@scheme[prop:rename-transformer] properties, then the latter takes +precedence. If a structure type has the @scheme[prop:set!-transformer] +and @scheme[prop:procedure] properties, then the former takes +precedence for the purposes of macro expansion.} + + +@defproc[(rename-transformer? [v any/c]) boolean?]{ + +Returns @scheme[#t] if @scheme[v] is a value created by +@scheme[make-rename-transformer] or an instance of a structure type +with the @scheme[prop:rename-transformer] property, @scheme[#f] +otherwise.} @defproc[(make-rename-transformer [id-stx syntax?] @@ -64,26 +102,55 @@ Returns the procedure that was passed to rename-transformer?]{ Creates a @tech{rename transformer} that, when used as a -@tech{transformer binding}, acts as a transformer that insert the +@tech{transformer binding}, acts as a transformer that inserts the identifier @scheme[id-stx] in place of whatever identifier binds the -transformer, including in non-application positions, and in -@scheme[set!] expressions. Such a transformer could be written -manually, but the one created by @scheme[make-rename-transformer] -cooperates specially with @scheme[syntax-local-value] and +transformer, including in non-application positions, in @scheme[set!] +expressions. + +Such a transformer could be written manually, but the one created by +@scheme[make-rename-transformer] also causes the parser to install a +@scheme[free-identifier=?] and @scheme[identifier-binding] +equivalence, as long as @scheme[id-stx] does not have a true value for +the @indexed-scheme['not-free-identifier=?] @tech{syntax property}. +Also, if @scheme[id-stx] has a true value for the +@indexed-scheme['not-provide-all-defined] @tech{syntax property} and +it is bound as a module-level transformer, the bound identifier is not +exported by @scheme[all-defined-out]; the @scheme[provide] form +otherwise uses a symbol-valued @indexed-scheme['nominal-id] property +of @scheme[id-stx] to specify the ``nominal source identifier'' of the +binding. Finally, the rename transformer cooperates specially with +@scheme[syntax-local-value] and @scheme[syntax-local-make-delta-introducer].} -@defproc[(rename-transformer? [v any/c]) boolean?]{ - -Returns @scheme[#t] if @scheme[v] is a value created by -@scheme[make-rename-transformer], @scheme[#f] otherwise.} - - @defproc[(rename-transformer-target [transformer rename-transformer?]) - syntax?]{ + identifier?]{ Returns the identifier passed to @scheme[make-rename-transformer] to -create @scheme[transformer].} +create @scheme[transformer] or as indicated by a +@scheme[prop:rename-transformer] property on @scheme[transformer].} + + +@defthing[prop:rename-transformer struct-type-property?]{ + +A @tech{structure type property} to indentify structure types that act +as @tech{rename transformers} like the ones created by +@scheme[make-rename-transformer]. + +The property value must be an exact integer or an identifier +@tech{syntax object}. In the former case, the integer designates a +field within the structure that should contain an identifier; the +integer must be between @scheme[0] (inclusive) and the number of +non-automatic fields in the structure type (exclusive, not counting +supertype fields), and the designated field must also be specified as +immutable. + +If the property value is an identifier, the identifier serves as the +target for renaming, just like the first argument to +@scheme[make-rename-transformer]. If the property value is an integer, +the target identifier is extracted from the structure instance; if the +field value is not an identifier, then an identifier @schemeidfont{?} +with an empty context is used, instead.} @defproc[(local-expand [stx syntax?] @@ -307,6 +374,28 @@ being expanded for the body of a module, then resolving @transform-time[]} +@defproc[(syntax-local-value/immediate [id-stx syntax?] + [failure-thunk (or/c (-> any) #f) + #f] + [intdef-ctx (or/c internal-definition-context? + #f) + #f]) + any]{ + +Like @scheme[syntax-local-value], but the result is normally two +values. If @scheme[id-stx] is bound to a @tech{rename transformer}, +the results are the rename transformer and the identifier in the +transformer augmented with certificates from @scheme[id-stx]. If +@scheme[id-stx] is not bound to a @tech{rename transformer}, then the +results are the value that @scheme[syntax-local-value] would produce +and @scheme[#f]. + +If @scheme[id-stx] has no transformer biding, then +@scheme[failure-thunk] is called (and it can return any number of +values), or an exception is raised if @scheme[failure-thunk] is +@scheme[#f].} + + @defproc[(syntax-local-lift-expression [stx syntax?]) identifier?]{ diff --git a/collects/scribblings/reference/syntax-model.scrbl b/collects/scribblings/reference/syntax-model.scrbl index dfa0d2bf55..1f080ca659 100644 --- a/collects/scribblings/reference/syntax-model.scrbl +++ b/collects/scribblings/reference/syntax-model.scrbl @@ -531,19 +531,28 @@ is the one left with a mark, and the reference @scheme[x] has no mark, so the binding @scheme[x] is not @scheme[bound-identifier=?] to the body @scheme[x]. -The @scheme[set!] form and the @scheme[make-set!-transformer] -procedure work together to support @deftech{assignment transformers} -that transformer @scheme[set!] expression. @tech{Assignment -transformers} are applied by @scheme[set!] in the same way as a normal +The @scheme[set!] form works with the @scheme[make-set!-transformer] +and @scheme[prop:set!-transformer] property to support +@deftech{assignment transformers} that transform @scheme[set!] +expressions. An @tech{assignment transformer} contains a procedure +that is applied by @scheme[set!] in the same way as a normal transformer by the expander. -The @scheme[make-rename-transformer] procedure creates a value that is -also handled specially by the expander and by @scheme[set!] as a +The @scheme[make-rename-transformer] procedure or +@scheme[prop:rename-transformer] property creates a value that is also +handled specially by the expander and by @scheme[set!] as a transformer binding's value. When @scheme[_id] is bound to a @deftech{rename transformer} produced by -@scheme[make-rename-transformer], it is replaced with the identifier -passed to @scheme[make-rename-transformer]. Furthermore, the binding -is also specially handled by @scheme[syntax-local-value] and +@scheme[make-rename-transformer], it is replaced with the target +identifier passed to @scheme[make-rename-transformer]. In addition, as +long as the target identifier does not have a true value for the +@scheme['not-free-identifier=?] @tech{syntax property}, the lexical information that +contains the binding of @scheme[_id] is also enriched so that +@scheme[_id] is @scheme[free-identifier=?] to the target identifier, +@scheme[identifier-binding] returns the same results for both +identifiers, and @scheme[provide] exports @scheme[_id] as the target +identifier. Finally, the binding is treated specially by +@scheme[syntax-local-value], and @scheme[syntax-local-make-delta-introducer] as used by @tech{syntax transformer}s. diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index 4548fdc229..3f25fb23c0 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -13,11 +13,13 @@ scheme/package scheme/splicing)) +@(define require-eval (make-base-eval)) @(define syntax-eval (lambda () (let ([the-eval (make-base-eval)]) (the-eval '(require (for-syntax scheme/base))) the-eval))) +@(define meta-in-eval (syntax-eval)) @(define cvt (schemefont "CVT")) @(define unquote-id (scheme unquote)) @@ -202,11 +204,13 @@ be preserved in marshaled bytecode. See also See also @secref["module-eval-model"] and @secref["mod-parse"]. @defexamples[#:eval (syntax-eval) -(module example-module scheme - (provide foo bar) - (define foo 2) - (define (bar x) - (+ x 1))) +(module duck scheme/base + (provide num-eggs quack) + (define num-eggs 2) + (define (quack n) + (unless (zero? n) + (printf "quack\n") + (quack (sub1 n))))) ] @defform[(#%module-begin form ...)]{ @@ -272,8 +276,8 @@ In a @tech{top-level context}, @scheme[require] instantiates modules (see @secref["module-eval-model"]). In a @tech{module context}, @scheme[require] @tech{visits} modules (see @secref["mod-parse"]). In both contexts, @scheme[require] introduces bindings into a -@tech{namespace} or a module (see @secref["intro-binding"]). A -@scheme[require] form in a @tech{expression context} or +@tech{namespace} or a module (see @secref["intro-binding"]). +A @scheme[require] form in a @tech{expression context} or @tech{internal-definition context} is a syntax error. A @scheme[require-spec] designates a particular set of identifiers to @@ -284,8 +288,11 @@ identifier. Each identifier also binds at a particular @tech{phase level}. The syntax of @scheme[require-spec] can be extended via -@scheme[define-require-syntax], but the -pre-defined forms are as follows. +@scheme[define-require-syntax], and when multiple +@scheme[require-spec]s are specified in a @scheme[require], the +bindings of each @scheme[require-spec] are visible for expanding later +@scheme[require-spec]s. The pre-defined forms (as exported by +@scheme[scheme/base]) are as follows: @specsubform[module-path]{ Imports all exported bindings from the named module, using the export identifiers as the local identifiers. @@ -364,56 +371,34 @@ pre-defined forms are as follows. binding that is not for @scheme[phase-level], where @scheme[#f] for @scheme[phase-level] corresponds to the @tech{label phase level}. - This example only imports bindings at @tech{phase level} 1, the - transform phase. + The following example imports bindings only at @tech{phase level} 1, + the transform phase: - @defexamples[#:eval (syntax-eval) - (module test scheme + @interaction[#:eval meta-in-eval + (module nest scheme + (provide (for-syntax meta-eggs) + (for-meta 1 meta-chicks) + num-eggs) + (define-for-syntax meta-eggs 2) + (define-for-syntax meta-chicks 3) + (define num-eggs 2)) - (provide (for-syntax meta-1a) - (for-meta 1 meta-1b) - meta-0) + (require (only-meta-in 1 'nest)) - (define-for-syntax meta-1a 'a) - (define-for-syntax meta-1b 'b) - (define meta-0 2)) + (define-syntax (desc stx) + (printf "~s ~s\n" meta-eggs meta-chicks) + #'(void)) - (require (only-meta-in 1 'test)) - - (define-syntax bar - (lambda (stx) - (printf "~a\n" meta-1a) - (printf "~a\n" meta-1b) - #'1)) - - (bar) - meta-0 + (desc) + num-eggs ] - This example only imports bindings at @tech{phase level} 0, the + The following example imports only bindings at @tech{phase level} 0, the normal phase. - @defexamples[#:eval (syntax-eval) - (module test scheme - - (provide (for-syntax meta-1a) - (for-meta 1 meta-1b) - meta-0) - - (define-for-syntax meta-1a 'a) - (define-for-syntax meta-1b 'b) - (define meta-0 2)) - - (require (only-meta-in 0 'test)) - - (define-syntax bar - (lambda (stx) - (printf "~a\n" meta-1a) - (printf "~a\n" meta-1b) - #'1)) - - meta-0 - (bar) + @interaction[#:eval meta-in-eval + (require (only-meta-in 0 'nest)) + num-eggs ]} @specsubform[#:literals (for-meta) @@ -424,23 +409,15 @@ pre-defined forms are as follows. combination that involves @scheme[#f] produces @scheme[#f]. @defexamples[#:eval (syntax-eval) - (module test scheme - (provide foo) - (define foo 2)) - (require (for-meta 0 'test)) - foo - ]} - - @defexamples[#:eval (syntax-eval) - (module test scheme - (provide foo) - (define foo 2)) - (require (for-meta 1 'test)) - (define-syntax bar - (lambda (stx) - (printf "~a\n" foo) - #'1)) - (bar) + (module nest scheme + (provide num-eggs) + (define num-eggs 2)) + (require (for-meta 0 'nest)) + num-eggs + (require (for-meta 1 'nest)) + (define-syntax (roost stx) + (datum->syntax stx num-eggs)) + (roost) ]} @specsubform[#:literals (for-syntax) @@ -456,7 +433,8 @@ pre-defined forms are as follows. @scheme[(for-meta #f require-spec ...)].} @specsubform[derived-require-spec]{See @scheme[define-require-syntax] - for information on expanding the set of @scheme[require-spec] forms.} + for information on expanding the set of @scheme[require-spec] + forms.} @guideintro["module-paths"]{module paths} @@ -523,8 +501,8 @@ corresponds to the default @tech{module name resolver}. @tech{collection}, and @filepath{main.ss} is the library file name. Example: require swindle - @defexamples[#:eval (syntax-eval) - (require (lib "swindle"))]} + @defexamples[#:eval require-eval + (eval:alts (require (lib "swindle")) (void))]} @item{If a single @scheme[rel-string] is provided, and if it consists of multiple @litchar{/}-separated elements, then each @@ -533,8 +511,8 @@ corresponds to the default @tech{module name resolver}. no file suffix, @filepath{.ss} is added. Example: require a file within the swindle collection - @defexamples[#:eval (syntax-eval) - (require (lib "swindle/turbo"))]} + @defexamples[#:eval require-eval + (eval:alts (require (lib "swindle/turbo")) (void))]} @item{If a single @scheme[rel-string] is provided, and if it consists of a single element @italic{with} a file suffix (i.e, @@ -543,8 +521,8 @@ corresponds to the default @tech{module name resolver}. compatibility with older version of PLT Scheme.) Example: require the tar module from mzlib - @defexamples[#:eval (syntax-eval) - (require (lib "tar.ss"))]} + @defexamples[#:eval require-eval + (eval:alts (require (lib "tar.ss")) (void))]} @item{Otherwise, when multiple @scheme[rel-string]s are provided, the first @scheme[rel-string] is effectively moved after the @@ -555,8 +533,8 @@ corresponds to the default @tech{module name resolver}. with older version of PLT Scheme.) Example: require the tar module from mzlib - @defexamples[#:eval (syntax-eval) - (require (lib "tar.ss" "mzlib"))]} + @defexamples[#:eval require-eval + (eval:alts (require (lib "tar.ss" "mzlib")) (void))]} }} @specsubform[id]{A shorthand for a @scheme[lib] form with a single @@ -564,14 +542,14 @@ corresponds to the default @tech{module name resolver}. form of @scheme[id]. In addition to the constraints of a @scheme[lib] @scheme[_rel-string], @scheme[id] must not contain @litchar{.}. - @defexamples[#:eval (syntax-eval) - (require scheme/tcp)]} + @examples[#:eval require-eval + (eval:alts (require scheme/tcp) (void))]} @defsubform[(file string)]{Similar to the plain @scheme[rel-string] case, but @scheme[string] is a path---possibly absolute---using the current platform's path conventions and @scheme[expand-user-path]. - @scheme[(require (file "~/tmp/x.ss"))]} + @examples[(eval:alts (require (file "~/tmp/x.ss")) (void))]} @defsubform*[((planet id) (planet string) @@ -631,27 +609,22 @@ corresponds to the default @tech{module name resolver}. identifiers in a minor-version constraint are recognized symbolically. - Example: Load main.ss file package foo owned by bar. - - @scheme[(require (planet bar/foo))] - - Example: Load major version 2 of main.ss file package foo owned by bar. - - @scheme[(require (planet bar/foo:2))] - - Example: Load major version 2 and minor version 5 of main.ss file package foo owned by bar. - - @scheme[(require (planet bar/foo:2:5))] - - Example: Load major version 2 and minor version 5 of buz.ss file package foo owned by bar. - - @scheme[(require (planet bar/foo:2:5/buz))]} + @examples[ + (code:comment #, @t{@filepath{main.ss} in package @filepath{farm} by @filepath{mcdonald}:}) + (eval:alts (require (planet mcdonald/farm)) (void)) + (code:comment #, @t{@filepath{main.ss} in version >= 2.0 of package @filepath{farm} by @filepath{mcdonald}:}) + (eval:alts (require (planet mcdonald/farm:2)) (void)) + (code:comment #, @t{@filepath{main.ss} in version >= 2.5 of package @filepath{farm} by @filepath{mcdonald}:}) + (eval:alts (require (planet mcdonald/farm:2:5)) (void)) + (code:comment #, @t{@filepath{duck.ss} in version >= 2.5 of package @filepath{farm} by @filepath{mcdonald}:}) + (eval:alts (require (planet mcdonald/farm:2:5/duck)) (void)) + ]} No identifier can be bound multiple times in a given @tech{phase level} by an import, unless all of the bindings refer to the same original definition in the same module. In a @tech{module context}, an identifier can be either imported or defined for a given -@tech{phase level}, but not both.} +@tech{phase level}, but not both.}} @guideintro["module-provide"]{@scheme[provide]} @@ -697,29 +670,37 @@ follows. ambiguous). @defexamples[#:eval (syntax-eval) - (module test scheme - (provide foo) - (define foo 2)) - (require 'test) - foo - ]} + (module nest scheme + (provide num-eggs) + (define num-eggs 2)) + (require 'nest) + num-eggs + ] + + If @scheme[id] has a transformer binding to a @tech{rename + transformer}, then the exported binding is the target identifier of + the @tech{rename transformer}, instead of @scheme[id], unless the + target identifier has a true value for the + @scheme['not-free-identifier=?] @tech{syntax property}.} @defsubform[(all-defined-out)]{ Exports all identifiers that are defined at @tech{phase level} 0 or @tech{phase level} 1 within the exporting module, and that have the same lexical context as the - @scheme[(all-defined-out)] form. The external name for each - identifier is the symbolic form of the identifier. Only identifiers - accessible from the lexical context of the @scheme[(all-defined-out)] - form are included; that is, macro-introduced imports are not - re-exported, unless the @scheme[(all-defined-out)] form was - introduced at the same time. + @scheme[(all-defined-out)] form, excluding bindings to @tech{rename + transformers} where the target identifier has the + @scheme['not-provide-all-defined] @tech{syntax property}. The + external name for each identifier is the symbolic form of the + identifier. Only identifiers accessible from the lexical context of + the @scheme[(all-defined-out)] form are included; that is, + macro-introduced imports are not re-exported, unless the + @scheme[(all-defined-out)] form was introduced at the same time. @defexamples[#:eval (syntax-eval) - (module test scheme + (module nest scheme (provide (all-defined-out)) - (define foo 2)) - (require 'test) - foo + (define num-eggs 2)) + (require 'nest) + num-eggs ]} @defsubform[(all-from-out module-path ...)]{ Exports all identifiers @@ -734,14 +715,14 @@ follows. @scheme[module-path] was introduced at the same time. @defexamples[#:eval (syntax-eval) - (module a scheme - (provide foo) - (define foo 2)) - (module b scheme - (require 'a) - (provide (all-from-out 'a))) - (require 'b) - foo + (module nest scheme + (provide num-eggs) + (define num-eggs 2)) + (module hen-house scheme + (require 'nest) + (provide (all-from-out 'nest))) + (require 'hen-house) + num-eggs ]} @defsubform[(rename-out [orig-id export-id] ...)]{ Exports each @@ -750,12 +731,12 @@ follows. @scheme[export-id] instead @scheme[orig-d]. @defexamples[#:eval (syntax-eval) - (module a scheme - (provide (rename-out (foo myfoo))) - (define foo 2)) - (require 'a) - foo - myfoo + (module nest scheme + (provide (rename-out [count num-eggs])) + (define count 2)) + (require 'nest) + num-eggs + count ]} @defsubform[(except-out provide-spec provide-spec ...)]{ Like the @@ -766,14 +747,14 @@ follows. @scheme[provide-spec]s is ignored; only the bindings are used. @defexamples[#:eval (syntax-eval) - (module a scheme + (module nest scheme (provide (except-out (all-defined-out) - bar)) - (define foo 2) - (define bar 3)) - (require 'a) - foo - bar + num-chicks)) + (define num-eggs 2) + (define num-chicks 3)) + (require 'nest) + num-eggs + num-chicks ]} @defsubform[(prefix-out prefix-id provide-spec)]{ @@ -781,11 +762,11 @@ follows. @scheme[provide-spec] prefixed with @scheme[prefix-id]. @defexamples[#:eval (syntax-eval) - (module a scheme - (provide (prefix-out f: foo)) - (define foo 2)) - (require 'a) - f:foo + (module nest scheme + (provide (prefix-out chicken: num-eggs)) + (define num-eggs 2)) + (require 'nest) + chicken:num-eggs ]} @defsubform[(struct-out id)]{Exports the bindings associated with a @@ -803,28 +784,24 @@ follows. included by @scheme[struct-out] for export. @defexamples[#:eval (syntax-eval) - (module a scheme - (provide (struct-out foo)) - (define-struct foo (a b c))) - (require 'a) - make-foo - foo-a - foo-b - foo-c - foo? + (module nest scheme + (provide (struct-out egg)) + (define-struct egg (color wt))) + (require 'nest) + (egg-color (make-egg 'blue 10)) ]} @defsubform[(combine-out provide-spec ...)]{ The union of the @scheme[provide-spec]s. @defexamples[#:eval (syntax-eval) - (module a scheme - (provide (combine-out foo bar)) - (define foo 2) - (define bar 1)) - (require 'a) - foo - bar + (module nest scheme + (provide (combine-out num-eggs num-chicks)) + (define num-eggs 2) + (define num-chicks 1)) + (require 'nest) + num-eggs + num-chicks ]} @defsubform[(protect-out provide-spec ...)]{ Like the union of the @@ -832,31 +809,19 @@ follows. @secref["modprotect"]. The @scheme[provide-spec] must specify only bindings that are defined within the exporting module. - @defexamples[#:eval (syntax-eval) - (module a scheme - (provide (protect-out foo)) - (define foo 1)) + @examples[#:eval (syntax-eval) + (module nest scheme + (provide num-eggs (protect-out num-chicks)) + (define num-eggs 2) + (define num-chicks 3)) (define weak-inspector (make-inspector (current-code-inspector))) (define (weak-eval x) (parameterize ([current-code-inspector weak-inspector]) (eval x))) - (require 'a) - foo - (weak-eval 'foo) - ] - - Note that @scheme[require] works within eval as well. - @defexamples[#:eval (syntax-eval) - (module a scheme - (provide (protect-out foo)) - (define foo 1)) - (define weak-inspector (make-inspector (current-code-inspector))) - (define (weak-eval x) - (parameterize ([current-code-inspector weak-inspector]) - (eval x))) - (weak-eval '(require 'a)) - foo - (weak-eval 'foo) + (require 'nest) + (list num-eggs num-chicks) + (weak-eval 'num-eggs) + (weak-eval 'num-chicks) ]} @specsubform[#:literals (for-meta) @@ -1005,21 +970,7 @@ context of the @scheme[phaseless-spec] form.} @note-lib-only[scheme/require] The following forms support more complex selection and manipulation of -sets of imported identifiers. Note that a @scheme[require] form is -expanded before it is used, which means that requiring the library -itself should be a separate form. For example, use - -@schemeblock[ - (require scheme/require) - (require (matching-identifiers-in #rx"foo" "foo.ss")) -] - -instead of - -@schemeblock[ - (require scheme/require - (matching-identifiers-in #rx"foo" "foo.ss")) -] +sets of imported identifiers. @defform[(matching-identifiers-in regexp require-spec)]{ Like @scheme[require-spec], but including only imports whose names match @@ -1047,7 +998,7 @@ instead of #rx"-" (string-titlecase name) ""))) scheme/base))] will get the @scheme[scheme/base] bindings that match the regexp, - and renamed to use ``camel case''.} + and renamed to use ``camel case.''} @; -------------------- @@ -1489,8 +1440,8 @@ created first and filled with @|undefined-const|, and all (or (zero? n) (is-odd? (sub1 n))))] [is-odd? (lambda (n) - (or (= n 1) - (is-even? (sub1 n))))]) + (and (not (zero? n)) + (is-even? (sub1 n))))]) (is-odd? 11)) ]} @@ -2109,14 +2060,19 @@ Equivalent to @scheme[(when (not test-expr) expr ...)]. @defform[(set! id expr)]{ -If @scheme[id] has a @tech{transformer binding} to an -@tech{assignment transformer}, as produced by -@scheme[make-set!-transformer], then this form is expanded by calling -the assignment transformer with the full expressions. If @scheme[id] -has a @tech{transformer binding} to a @tech{rename transformer} as -produced by @scheme[make-rename-transformer], then this form is -expanded by replacing @scheme[id] with the one provided to -@scheme[make-rename-transformer]. +If @scheme[id] has a @tech{transformer binding} to an @tech{assignment +transformer}, as produced by @scheme[make-set!-transformer] or as an +instance of a structure type with the @scheme[prop:set!-transformer] +property, then this form is expanded by calling the assignment +transformer with the full expressions. If @scheme[id] has a +@tech{transformer binding} to a @tech{rename transformer} as produced +by @scheme[make-rename-transformer] or as an instance of a structure +type with the @scheme[prop:rename-transformer] property, then this +form is expanded by replacing @scheme[id] with the target identifier +(e.g., the one provided to @scheme[make-rename-transformer]). If a +transformer binding has both @scheme[prop:set!-transformer] ad +@scheme[prop:rename-transformer] properties, the latter takes +precedence. Otherwise, evaluates @scheme[expr] and installs the result into the location for @scheme[id], which must be bound as a local variable or @@ -2344,3 +2300,7 @@ than a precise prose description: [(nest ([form forms ...] . more) body0 body ...) (form forms ... (nest more body0 body ...))])) ]} + + +@close-eval[require-eval] +@close-eval[meta-in-eval] diff --git a/collects/scribblings/reference/time.scrbl b/collects/scribblings/reference/time.scrbl index ca72c8637b..2c28abea77 100644 --- a/collects/scribblings/reference/time.scrbl +++ b/collects/scribblings/reference/time.scrbl @@ -72,12 +72,16 @@ Like @scheme[current-milliseconds], but the result never decreases (until the machine is turned off).} -@defproc[(current-process-milliseconds) exact-integer?]{ +@defproc[(current-process-milliseconds [thread (or/c thread? #f)]) + exact-integer?]{ -Returns the amount of processor time in @tech{fixnum} milliseconds +Returns an amount of processor time in @tech{fixnum} milliseconds that has been consumed by the Scheme process on the underlying operating system. (Under @|AllUnix|, this includes both user and -system time.) The precision of the result is platform-specific, and +system time.) If @scheme[thread] is @scheme[#f], the reported time +is for all Scheme threads, otherwise the result is specific to the +time while @scheme[thread] ran. +The precision of the result is platform-specific, and since the result is a @tech{fixnum}, the value increases only over a limited (though reasonably long) time.} diff --git a/collects/scribblings/scribble/preprocessor.scrbl b/collects/scribblings/scribble/preprocessor.scrbl index c393f0b13d..5d34ef68c6 100644 --- a/collects/scribblings/scribble/preprocessor.scrbl +++ b/collects/scribblings/scribble/preprocessor.scrbl @@ -1,7 +1,10 @@ #lang scribble/doc -@(require scribble/manual - "utils.ss" - (for-label scheme/base)) +@(require scribble/manual scribble/struct "utils.ss" + (for-label scheme/base + ;; FIXME: need to get this in + ;; scribble/text + )) +@initialize-tests @title[#:tag "preprocessor"]{Text Preprocessor} @@ -12,63 +15,1161 @@ changes that make it suitable as a preprocessor language: @itemize{ @item{It uses @scheme[read-syntax-inside] to read the body of the - module, similar to @secref["docreader"].} + module, similar to @secref["docreader"]. This means that by + default, all text is read in as Scheme strings; and + @seclink["reader"]|{@-forms}| can be used to use Scheme + functions and expression escapes.} - @item{It has a custom printer (@scheme[current-print]) that displays - all values. The printer is also installed as the - @scheme[port-display-handler] so it can be used through - @scheme[display] as well as @litchar{~a} in format strings. - The printer displays most values (as is usual for - @scheme[display]), except for - @itemize{@item{@scheme[void] and @scheme[#f] are not - displayed,} - @item{pairs are displayed recursively (just their - contents, no parentheses),} - @item{promises are forced, thunks are invoked.}}}} + @item{Values of expressions are printed with a custom + @scheme[output] function. This function displays most values + in a similar way to @scheme[display], except that it is more + convenient for a preprocessor output.}} } -This means that to write a text file that has scheme code, you simply -write it as a module in the @scheme[scribble/text] language, and run -it through @exec{mzscheme}. Here is a sample file: +@; TODO: +@; * make all example sections be subsections, +@; * add a reference section, +@; * a section on "scribble/text.ss" +@; * maybe a section on additional utilities: begin/text -@verbatim[#:indent 2]|{ +@;-------------------------------------------------------------------- +@section{Writing Preprocessor Files} + +The combination of the two features makes text in files in the +@scheme[scribble/text] language be read as strings, which get printed +out when the module is @scheme[require]d, for example, when a file is +given as an argument to @exec{mzscheme}. (In these example the left +part shows the source input, and the right part the printed result.) + +@example|-{#lang scribble/text + Programming languages should + be designed not by piling + feature on top of feature, but + blah blah blah. + ---***--- + Programming languages should + be designed not by piling + feature on top of feature, but + blah blah blah.}-| + +Using @seclink["reader"]|{@-forms}|, we can define and use Scheme +functions. + +@example|-{#lang scribble/text + @(require scheme/list) + @(define Foo "Preprocessing") + @(define (3x . x) + ;; scheme syntax here + (add-between (list x x x) " ")) + @Foo languages should + be designed not by piling + feature on top of feature, but + @3x{blah}. + ---***--- + Preprocessing languages should + be designed not by piling + feature on top of feature, but + blah blah blah.}-| + +As demonstrated in this case, the @scheme[output] function simply +scans nested list structures recursively, which makes them convenient +for function results. In addition, @scheme[output] prints most values +similarly to @scheme[display] --- notable exceptions are void and +false values which cause no output to appear. This can be used for +convenient conditional output. + +@example|-{#lang scribble/text + @(define (errors n) + (list n + " error" + (and (not (= n 1)) "s"))) + You have @errors[3] in your code, + I fixed @errors[1]. + ---***--- + You have 3 errors in your code, + I fixed 1 error.}-| + +Using the scribble @seclink["reader"]|{@-forms}| syntax, you can write +functions more conveniently too. + +@example|-{#lang scribble/text + @(define (errors n) + ;; note the use of `unless' + @list{@n error@unless[(= n 1)]{s}}) + You have @errors[3] in your code, + I fixed @errors[1]. + ---***--- + You have 3 errors in your code, + I fixed 1 error.}-| + +Following the details of the scribble reader, you may notice that in +these examples there are newline strings after each definition, yet +they do not show in the output. To make it easier to write +definitions, newlines after definitions and indentation spaces before +them are ignored. + +@example|-{#lang scribble/text + + @(define (plural n) + (unless (= n 1) "s")) + + @(define (errors n) + @list{@n error@plural[n]}) + + You have @errors[3] in your code, + @(define fixed 1) + I fixed @errors[fixed]. + ---***--- + You have 3 errors in your code, + I fixed 1 error.}-| + +These end-of-line newline strings are not ignored when they follow +other kinds of expressions, which may lead to redundant empty lines in +the output. + +@example|-{#lang scribble/text + @(define (count n str) + (for/list ([i (in-range 1 (add1 n))]) + @list{@i @str,@"\n"})) + Start... + @count[3]{Mississippi} + ... and I'm done. + ---***--- + Start... + 1 Mississippi, + 2 Mississippi, + 3 Mississippi, + + ... and I'm done.}-| + +There are several ways to avoid having such empty lines in your +output. The simplest way is to arrange for the function call's form +to end right before the next line begins, but this is often not too +convenient. An alternative is to use a @litchar|{@;}| comment, which +makes the scribble reader ignore everything that follows it up to and +including the newline. (These methods can be applied to the line that +precedes the function call too, but the results are likely to have +what looks like erroneous indentation. More about this below.) + +@example|-{#lang scribble/text + @(define (count n str) + (for/list ([i (in-range 1 (+ n 1))]) + @list{@i @str,@"\n"})) + Start... + @count[3]{Mississippi + }... done once. + + Start again... + @count[3]{Massachusetts}@; + ... and I'm done again. + ---***--- + Start... + 1 Mississippi, + 2 Mississippi, + 3 Mississippi, + ... done once. + + Start again... + 1 Massachusetts, + 2 Massachusetts, + 3 Massachusetts, + ... and I'm done again.}-| + +A better approach is to generate newlines only when needed. + +@example|-{#lang scribble/text + @(require scheme/list) + @(define (count n str) + (add-between + (for/list ([i (in-range 1 (+ n 1))]) + @list{@i @str,}) + "\n")) + Start... + @count[3]{Mississippi} + ... and I'm done. + ---***--- + Start... + 1 Mississippi, + 2 Mississippi, + 3 Mississippi, + ... and I'm done.}-| + +In fact, this is common enough that the @scheme[scribble/text] +language provides a convenient facility: @scheme[add-newlines] is a +function that is similar to @scheme[add-between] using a newline +string as the default separator, except that false and void values are +filtered out before doing so. + +@example|-{#lang scribble/text + @(define (count n str) + (add-newlines + (for/list ([i (in-range 1 (+ n 1))]) + @list{@i @str,}))) + Start... + @count[3]{Mississippi} + ... and I'm done. + ---***--- + Start... + 1 Mississippi, + 2 Mississippi, + 3 Mississippi, + ... and I'm done.}-| + +@example|-{#lang scribble/text + @(define (count n str) + (add-newlines + (for/list ([i (in-range 1 (+ n 1))]) + @(and (even? i) @list{@i @str,})))) + Start... + @count[6]{Mississippi} + ... and I'm done. + ---***--- + Start... + 2 Mississippi, + 4 Mississippi, + 6 Mississippi, + ... and I'm done.}-| + +The separator can be set to any value. + +@example|-{#lang scribble/text + @(define (count n str) + (add-newlines #:sep ",\n" + (for/list ([i (in-range 1 (+ n 1))]) + @list{@i @str}))) + Start... + @count[3]{Mississippi}. + ... and I'm done. + ---***--- + Start... + 1 Mississippi, + 2 Mississippi, + 3 Mississippi. + ... and I'm done.}-| + + +@;-------------------------------------------------------------------- +@section{Defining Functions and More} + +(Note: most of the tips in this section are applicable to any code +that uses the Scribble @"@"-form syntax.) + +Because the Scribble reader is uniform, you can use it in place of any +expression where it is more convenient. (By convention, we use a +plain S-expression syntax when we want a Scheme expression escape, and +an @"@"-form for expressions that render as text, which, in the +@scheme[scribble/text] language, is any value-producing expression.) +For example, you can use an @"@"-form for a function that you define. + +@example|-{#lang scribble/text + @(define @bold[text] @list{*@|text|*}) + An @bold{important} note. + ---***--- + An *important* note. + }-| + +This is not commonly done, since most functions that operate with text +will need to accept a variable number of arguments. In fact, this +leads to a common problem: what if we want to write a function that +consumes a number of ``text arguments'' rathen than a single +``rest-like'' body? The common solution for this is to provide the +separate text arguments in the S-expression part of an @"@"-form. + +@example|-{#lang scribble/text + @(define (choose 1st 2nd) + @list{Either @1st, or @2nd@"."}) + @(define who "us") + @choose[@list{you're with @who} + @list{against @who}] + ---***--- + Either you're with us, or against us. + }-| + +You can even use @"@"-forms with a Scheme quote or quasiquote as the +``head'' part to make it shorter, or use a macro to get grouping of +sub-parts without dealing with quotes. + +@example|-{#lang scribble/text + @(define (choose 1st 2nd) + @list{Either @1st, or @2nd@"."}) + @(define who "us") + @choose[@list{you're with @who} + @list{against @who}] + @(define-syntax-rule (compare (x ...) ...) + (add-newlines + (list (list "* " x ...) ...))) + Shopping list: + @compare[@{apples} + @{oranges} + @{@(* 2 3) bananas}] + ---***--- + Either you're with us, or against us. + Shopping list: + * apples + * oranges + * 6 bananas + }-| + +Yet another solution is to look at the text values and split the input +arguments based on a specific token. Using @scheme[match] can make it +convenient --- you can even specify the patterns with @"@"-forms. + +@example|-{#lang scribble/text + @(require scheme/match) + @(define (features . text) + (match text + [@list{@1st@... + --- + @2nd@...} + @list{>> Pros << + @1st; + >> Cons << + @|2nd|.}])) + @features{fast, + reliable + --- + expensive, + ugly} + ---***--- + >> Pros << + fast, + reliable; + >> Cons << + expensive, + ugly. + }-| + +In particular, it is often convenient to split the input by lines, +identified by delimiting @scheme["\n"] strings. Since this can be +useful, a @scheme[split-lines] function is provided. + +@example|-{#lang scribble/text + @(require scheme/list) + @(define (features . text) + (add-between (split-lines text) + ", ")) + @features{red + fast + reliable}. + ---***--- + red, fast, reliable. + }-| + +Finally, the Scribble reader accepts @emph{any} expression as the head +part of an @"@"-form --- even an @"@" form. This makes it possible to +get a number of text bodies by defining a curried function, where each +step accepts any number of arguments. This, however, means that the +number of body expressions must be fixed. + +@example|-{#lang scribble/text + @(define ((choose . 1st) . 2nd) + @list{Either you're @1st, or @2nd@"."}) + @(define who "me") + @@choose{with @who}{against @who} + ---***--- + Either you're with me, or against me. + }-| + + +@;-------------------------------------------------------------------- +@section{Using Printouts} + +Because the preprocessor language simply displays each toplevel value +as the file is run, it is possible to print text directly as part of +the output. + +@example|-{#lang scribble/text + First + @display{Second} + Third + ---***--- + First + Second + Third}-| + +Taking this further, it is possible to write functions that output +some text @emph{instead} of returning values that represent the text. + +@example|-{#lang scribble/text + @(define (count n) + (for ([i (in-range 1 (+ n 1))]) + (printf "~a Mississippi,\n" i))) + Start... + @count[3]@; avoid an empty line + ... and I'm done. + ---***--- + Start... + 1 Mississippi, + 2 Mississippi, + 3 Mississippi, + ... and I'm done.}-| + +This can be used to produce a lot of output text, even infinite. + +@example|-{#lang scribble/text + @(define (count n) + (printf "~a Mississippi,\n" n) + (count (add1 n))) + Start... + @count[1] + this line is never printed! + ---***--- + Start... + 1 Mississippi, + 2 Mississippi, + 3 Mississippi, + 4 Mississippi, + 5 Mississippi, + ...}-| + +However, you should be careful not to mix returning values with +printouts, as the results are rarely desirable. + +@example|-{#lang scribble/text + @list{1 @display{two} 3} + ---***--- + two1 3}-| + +Note that you don't need side-effects if you want infinite output. +The @scheme[output] function iterates thunks and (composable) +promises, so you can create a loop that is delayed in either form. +@; Note: there is some sfs-related problem in mzscheme that makes it not +@; run in bounded space, so don't show it for nowx. + +@example|-{#lang scribble/text + @(define (count n) + (cons @list{@n Mississippi,@"\n"} + (lambda () + (count (add1 n))))) + Start... + @count[1] + this line is never printed! + ---***--- + Start... + 1 Mississippi, + 2 Mississippi, + 3 Mississippi, + 4 Mississippi, + 5 Mississippi, + ...}-| + + +@;-------------------------------------------------------------------- +@section{Indentation in Preprocessed output} + +An issue that can be very important in many preprocessor applications +is the indentation of the output. This can be crucial in some cases, +if you're generating code for an indentation-sensitive language (e.g., +Haskell, Python, or C preprocessor directives). To get a better +understanding of how the pieces interact, you may want to review how +the @seclink["reader"]|{Scribble reader}| section, but also remember +that you can use quoted forms to see how some form is read. + +@example|-{#lang scribble/text + @(format "~s" '@list{ + a + b + c}) + ---***--- + (list "a" "\n" " " "b" "\n" "c")}-| + +The Scribble reader ignores indentation spaces in its body. This is +an intentional feature, since you usually do not want an expression to +depend on its position in the source. But the question is how +@emph{can} we render some output text with proper indentation. The +@scheme[output] function achieves that by assigning a special meaning +to lists: when a newline is part of a list's contents, it causes the +following text to appear with indentation that corresponds to the +column position at the beginning of the list. In most cases, this +makes the output appear ``as intended'' when lists are used for nested +pieces of text --- either from a literal @scheme[list] expression, or +an expression that evaluates to a list, or when a list is passed on as +a value; either as a toplevel expression, or as a nested value; either +appearing after spaces, or after other output. + +@example|-{#lang scribble/text + foo @list{1 + 2 + 3} + ---***--- + foo 1 + 2 + 3}-| + +@example|-{#lang scribble/text + @(define (block . text) + @list{begin + @text + end}) + @block{first + second + @block{ + third + fourth} + last} + ---***--- + begin + first + second + begin + third + fourth + end + last + end}-| + +@example|-{#lang scribble/text + @(define (enumerate . items) + (add-newlines #:sep ";\n" + (for/list ([i (in-naturals 1)] + [item (in-list items)]) + @list{@|i|. @item}))) + Todo: @enumerate[@list{Install PLT Scheme} + @list{Hack, hack, hack} + @list{Profit}]. + ---***--- + Todo: 1. Install PLT Scheme; + 2. Hack, hack, hack; + 3. Profit.}-| + +@example[#:hidden]|-{ #lang scribble/text - @(define (angled . body) (list "<" body ">"))@; - @(define (shout . body) @angled[(map string-upcase body)])@; - blah @angled{blah @shout{blah} blah} blah -}| + @; demonstrates how indentation is preserved inside lists + begin + a + b + @list{c + d + @list{e + f + g} + h + i + @list{j + k + l} + m + n + o} + p + q + end + ---***--- + begin + a + b + c + d + e + f + g + h + i + j + k + l + m + n + o + p + q + end + }-| -(Note how @litchar["@;"] is used to avoid empty lines in the output.) +@example[#:hidden]|-{ + #lang scribble/text + + @list{ + a + + b + } + + c + ---***--- + a + + b + + c + }-| + +@example[#:hidden]|-{ + #lang scribble/text + @; indentation works even when coming from a function + @(define (((if . c) . t) . e) + @list{ + if (@c) + @t + else + @e + fi}) + function foo() { + @list{if (1 < 2) + something1 + else + @@@if{2<3}{something2}{something3} + repeat 3 { + @@@if{2<3}{something2}{something3} + @@@if{2<3}{ + @list{something2.1 + something2.2} + }{ + something3 + } + } + fi} + return + } + ---***--- + function foo() { + if (1 < 2) + something1 + else + if (2<3) + something2 + else + something3 + fi + repeat 3 { + if (2<3) + something2 + else + something3 + fi + if (2<3) + something2.1 + something2.2 + else + something3 + fi + } + fi + return + } + }-| + +@example[#:hidden]|-{ + #lang scribble/text + @; indentation works with a list, even a single string with a newline + @; in a list, but not in a string by itself + function foo() { + prefix + @list{if (1 < 2) + something1 + else + @list{something2 + something3} + @'("something4\nsomething5") + @"something6\nsomething7" + fi} + return + } + @; can be used with a `display', but makes sense only at the top level + @; or in thunks (not demonstrated here) + @(display 123) foo @list{bar1 + bar2 + bar2} + ---***--- + function foo() { + prefix + if (1 < 2) + something1 + else + something2 + something3 + something4 + something5 + something6 + something7 + fi + return + } + 123 foo bar1 + bar2 + bar2 + }-| + +There are, however, cases when you need more refined control over the +output. The @scheme[scribble/text] provides a few functions for such +cases. The @scheme[splice] function is used to group together a +number of values but avoid introducing a new indentation context. + +@example|-{#lang scribble/text + @(define (block . text) + @splice{{ + blah(@text); + }}) + start + @splice{foo(); + loop:} + @list{if (something) @block{one, + two}} + end + ---***--- + start + foo(); + loop: + if (something) { + blah(one, + two); + } + end + }-| + +The @scheme[verbatim] function disables all indentation printouts in +its contents, including the indentation before the verbatim value +itself. It is useful, for example, to print out CPP directives. + +@example|-{#lang scribble/text + @(define (((IFFOO . var) . expr1) . expr2) + (define (array e1 e2) + @list{[@e1, + @e2]}) + @list{var @var; + @verbatim{#ifdef FOO} + @var = @array[expr1 expr2]; + @verbatim{#else} + @var = @array[expr2 expr1]; + @verbatim{#endif}}) + + function blah(something, something_else) { + @verbatim{#include "stuff.inc"} + @@@IFFOO{i}{something}{something_else} + } + ---***--- + function blah(something, something_else) { + #include "stuff.inc" + var i; + #ifdef FOO + i = [something, + something_else]; + #else + i = [something_else, + something]; + #endif + } + }-| + +If there are values after a @scheme[verbatim] value on the same line +will, they will get indented to the goal column (unless the output is +already beyond it). + +@example|-{#lang scribble/text + @(define (thunk name . body) + @list{function @name() { + @body + }}) + @(define (ifdef cond then else) + @list{@verbatim{#}ifdef @cond + @then + @verbatim{#}else + @else + @verbatim{#}endif}) + + @thunk['do_stuff]{ + init(); + @ifdef["HAS_BLAH" + @list{var x = blah();} + @thunk['blah]{ + @ifdef["BLEHOS" + @list{@verbatim{#}include + bleh();} + @list{error("no bleh");}] + }] + more_stuff(); + } + ---***--- + function do_stuff() { + init(); + # ifdef HAS_BLAH + var x = blah(); + # else + function blah() { + # ifdef BLEHOS + # include + bleh(); + # else + error("no bleh"); + # endif + } + # endif + more_stuff(); + } + }-| + +There are cases where each line should be prefixed with some string +other than a plain indentation. The @scheme[prefix] function causes +its contents to be printed using some given string prefix for every +line. The prefix gets accumulated to an existing indentation, and +indentation in the contents gets added to the prefix. + +@example|-{#lang scribble/text + @(define (comment . body) + @prefix["// "]{@body}) + @comment{add : int int -> string} + char *foo(int x, int y) { + @comment{ + skeleton: + allocate a string + print the expression into it + @comment{...more work...} + } + char *buf = malloc(@comment{FIXME! + This is bad} + 100); + } + ---***--- + // add : int int -> string + char *foo(int x, int y) { + // skeleton: + // allocate a string + // print the expression into it + // // ...more work... + char *buf = malloc(// FIXME! + // This is bad + 100); + } + }-| + +Trying to combine @scheme[prefix] and @scheme[verbatim] is more useful +using an additional value: @scheme[flush] is bound to a value that +causes @scheme[output] to print the current indentation and prefix. +It makes it possible to get the ``ignored as a prefix'' property of +@scheme[verbatim] but only for a nested prefix. + +@example|-{#lang scribble/text + @(define (comment . text) + (list flush + @prefix[" *"]{ + @verbatim{/*} @text */})) + function foo(x) { + @comment{blah + more blah + yet more blah} + if (x < 0) { + @comment{even more + blah here + @comment{even + nested}} + do_stuff(); + } + } + ---***--- + function foo(x) { + /* blah + * more blah + * yet more blah */ + if (x < 0) { + /* even more + * blah here + * /* even + * * nested */ */ + do_stuff(); + } + } + }-| + +@example[#:hidden]|-{ + #lang scribble/text + + @(begin + ;; This is a somewhat contrived example, showing how to use lists + ;; and verbatim to control the added prefix + (define (item . text) + ;; notes: the `flush' makes the prefix to that point print so the + ;; verbatim "* " is printed after it, which overwrites the "| " + ;; prefix + (list flush (prefix "| " (verbatim "* ") text))) + ;; note that a simple item with spaces is much easier: + (define (simple . text) @list{* @text})) + + start + @item{blah blah blah + blah blah blah + @item{more stuff + more stuff + more stuff} + blah blah blah + blah blah blah} + @simple{more blah + blah blah} + end + ---***--- + start + * blah blah blah + | blah blah blah + | * more stuff + | | more stuff + | | more stuff + | blah blah blah + | blah blah blah + * more blah + blah blah + end + }-| @;-------------------------------------------------------------------- @section{Using External Files} Using additional files that contain code for your preprocessing is -trivial: the preprocessor source is a plain Scheme file, so you can -@scheme[require] additional files as usual. +trivial: the preprocessor source is still source code in a module, so +you can @scheme[require] additional files with utility functions. -However, things can become tricky if you want to include an external -file that should also be preprocessed. Using @scheme[require] with a -text file (that uses the @scheme[scribble/text] language) almost -works, but when a module is required, it is invoked before the current -module, which means that the required file will be preprocessed before -the current file regardless of where the @scheme[require] expression -happens to be. Alternatively, you can use @scheme[dynamic-require] -with @scheme[#f] for the last argument (which makes it similar to a -plain @scheme[load])---but remember that the path will be relative to -the current directory, not to the source file. +@example|-{#lang scribble/text + @(require "itemize.ss") + Todo: + @itemize[@list{Hack some} + @list{Sleep some} + @list{Hack some + more}] + ---***--- itemize.ss + #lang scheme + (provide itemize) + (define (itemize . items) + (add-between (map (lambda (item) + (list "* " item)) + items) + "\n")) + ---***--- + Todo: + * Hack some + * Sleep some + * Hack some + more + }-| -Finally, there is a convenient syntax for including text files to be -processed: +Note that the @seclink["at-exp-lang"]{@scheme[at-exp] language} can +often be useful here, since such files need to deal with texts. Using +it, it is easy to include a lot of textual content. -@defform[(include filename)]{ +@example|-{#lang scribble/text + @(require "stuff.ss") + Todo: + @itemize[@list{Hack some} + @list{Sleep some} + @list{Hack some + more}] + @summary + ---***--- stuff.ss + #lang at-exp scheme/base + (require scheme/list) + (provide (all-defined-out)) + (define (itemize . items) + (add-between (map (lambda (item) + @list{* @item}) + items) + "\n")) + (define summary + @list{If that's not enough, + I don't know what is.}) + ---***--- + Todo: + * Hack some + * Sleep some + * Hack some + more + If that's not enough, + I don't know what is. + }-| -Preprocess the @scheme[filename] using the same syntax as -@scheme[scribble/text]. This is similar to using @scheme[load] in a -namespace that can access names bound in the current file so included -code can refer to bindings from the including module. Note, however, -that the including module cannot refer to names that are bound the -included file because it is still a plain scheme module---for such -uses you should still use @scheme[require] as usual.} +Of course, the extreme side of this will be to put all of your content +in a plain Scheme module, using @"@"-forms for convenience. However, +there is no need to use the preprocessor language in this case; +instead, you can @scheme[(require scribble/text)], which will get all +of the bindings that are available in the @scheme[scribble/text] +language. Using @scheme[output], switching from a preprocessed files +to a Scheme file is very easy ---- choosing one or the other depends +on whether it is more convenient to write a text file with occasional +Scheme expressions or the other way. + +@example|-{#lang at-exp scheme/base + @(require scribble/text scheme/list) + (define (itemize . items) + (add-between (map (lambda (item) + @list{* @item}) + items) + "\n")) + (define summary + @list{If that's not enough, + I don't know what is.}) + @(output + @list{ + Todo: + @itemize[@list{Hack some} + @list{Sleep some} + @list{Hack some + more}] + @summary + }) + ---***--- + Todo: + * Hack some + * Sleep some + * Hack some + more + If that's not enough, + I don't know what is. + }-| + +However, you might run into a case where it is desirable to include a +mostly-text file from a preprocessor file. It might be because you +prefer to split the source text to several files, or because you need +to preprocess a file without even a @litchar{#lang} header (for +example, an HTML template file that is the result of an external +editor). For these cases, the @scheme[scribble/text] language +provides an @scheme[include] form that includes a file in the +preprocessor syntax (where the default parsing mode is text). + + +@example|-{#lang scribble/text + @(require scheme/list) + @(define (itemize . items) + (list + "
    " + (add-between + (map (lambda (item) + @list{
  • @|item|
    • }) + items) + "\n") + "
")) + @(define title "Todo") + @(define summary + @list{If that's not enough, + I don't know what is.}) + + @include["template.html"] + ---***--- template.html + + @|title| + +

@|title|

+ @itemize[@list{Hack some} + @list{Sleep some} + @list{Hack some + more}] +

@|summary|

+ + + ---***--- + + Todo + +

Todo

+
  • Hack some
    • +
  • Sleep some
    • +
  • Hack some + more
+

If that's not enough, + I don't know what is.

+ + + }-| + +(Using @scheme[require] with a text file in the @scheme[scribble/text] +language will not work as intended: using the preprocessor language +means that the text is displayed when the module is invoked, so the +required file's contents will be printed before any of the requiring +module's text does. If you find yourself in such a situation, it is +better to switch to a Scheme-with-@"@"-expressions file as shown +above.) + +@;FIXME: add this to the reference section +@;@defform[(include filename)]{ +@; +@;Preprocess the @scheme[filename] using the same syntax as +@;@scheme[scribble/text]. This is similar to using @scheme[load] in a +@;namespace that can access names bound in the current file so included +@;code can refer to bindings from the including module. Note, however, +@;that the including module cannot refer to names that are bound the +@;included file because it is still a plain scheme module---for such +@;uses you should still use @scheme[require] as usual.} + + +@; Two random tests +@example[#:hidden]|-{ + #lang scribble/text + + @define[name]{PLT Scheme} + + Suggested price list for "@name" + + @; test mutual recursion, throwing away inter-definition spaces + @; <-- this is needed to get only one line of space above + @(define (items-num) + (length items)) + + @(define average + (delay (/ (apply + (map car items)) (length items)))) + + @(define items + (list @list[99]{Home} + @list[149]{Professional} + @list[349]{Enterprize})) + + @(for/list ([i items] [n (in-naturals)]) + @list{@|n|. @name @cadr[i] edition: $@car[i].99 + @||})@; <-- also needed + + Total: @items-num items + Average price: $@|average|.99 + ---***--- + Suggested price list for "PLT Scheme" + + 0. PLT Scheme Home edition: $99.99 + 1. PLT Scheme Professional edition: $149.99 + 2. PLT Scheme Enterprize edition: $349.99 + + Total: 3 items + Average price: $199.99 + }-| +@example[#:hidden]|-{ + #lang scribble/text + + --*-- + @(define (angled . body) (list "<" body ">")) + @(define (shout . body) @angled[(map string-upcase body)]) + @define[z]{blah} + + blah @angled{blah @shout{@z} blah} blah + + @(define-syntax-rule @twice[x] + (list x ", " x)) + + @twice{@twice{blah}} + + @include{inp1} + + @(let ([name "Eli"]) (let ([foo (include "inp2")]) (list foo "\n" foo))) + Repeating yourself much? + ---***--- inp1 + Warning: blah overdose might be fatal + ---***--- inp2 + @(define (foo . xs) (bar xs)) + @(begin (define (isname) @list{is @foo{@name}}) + (define-syntax-rule (DEF x y) (define x y))) + @(DEF (bar x) (list z " " x)) + @(define-syntax-rule (BEG x ...) (begin x ...)) + @(BEG (define z "zee")) + + My name @isname + @DEF[x]{Foo!} + + ... and to that I say "@x", I think. + + ---***--- + --*-- + blah blah> blah + + blah, blah, blah, blah + + Warning: blah overdose might be fatal + + My name is zee Eli + ... and to that I say "Foo!", I think. + My name is zee Eli + ... and to that I say "Foo!", I think. + Repeating yourself much? + }-| diff --git a/collects/scribblings/scribble/scheme.scrbl b/collects/scribblings/scribble/scheme.scrbl index 5c7376738b..9f991404cc 100644 --- a/collects/scribblings/scribble/scheme.scrbl +++ b/collects/scribblings/scribble/scheme.scrbl @@ -90,7 +90,8 @@ typically used to typeset results.} When @scheme[to-paragraph] and variants encounter a @scheme[var-id] structure, it is typeset as @scheme[sym] in the variable font, like -@scheme[schemevarfont].} +@scheme[schemevarfont]---unless the @scheme[var-id] appears under +quote or quasiquote, in which case @scheme[sym] is typeset as a symbol.} @defstruct[shaped-parens ([val any/c] @@ -149,4 +150,5 @@ Provided @scheme[for-syntax]; returns @scheme[#t] if @scheme[v] is an Provided @scheme[for-syntax]; like @scheme[element-id-transformer] for a transformer that produces @scheme[sym] typeset as a variable (like -@scheme[schemevarfont]).} +@scheme[schemevarfont])---unless it appears under quote or quasiquote, +in which case @scheme[sym] is typeset as a symbol.} diff --git a/collects/scribblings/scribble/struct.scrbl b/collects/scribblings/scribble/struct.scrbl index 5809ba0bae..60bb8e19d2 100644 --- a/collects/scribblings/scribble/struct.scrbl +++ b/collects/scribblings/scribble/struct.scrbl @@ -426,7 +426,8 @@ The @scheme[style] can be any of the following: @item{@scheme['valignment] to a list of symbols and @scheme[#f]s (one for each column); each symbol can be - @scheme['top], @scheme['baseline], or @scheme['bottom].} + @scheme['top], @scheme['baseline], @scheme['center], + or @scheme['bottom].} @item{@scheme['row-styles] to a list of association lists, one for each row in the table. Each of these nested diff --git a/collects/scribblings/scribble/utils.ss b/collects/scribblings/scribble/utils.ss index a1f581a00c..abf1581aeb 100644 --- a/collects/scribblings/scribble/utils.ss +++ b/collects/scribblings/scribble/utils.ss @@ -1,120 +1,211 @@ +#lang scheme/base -(module utils scheme/base - (require scribble/struct - scribble/manual - (prefix-in scheme: scribble/scheme) - (prefix-in scribble: scribble/reader)) +(require scribble/struct + scribble/manual + (prefix-in scheme: scribble/scheme) + (prefix-in scribble: scribble/reader)) - (define-syntax bounce-for-label - (syntax-rules (all-except) - [(_ (all-except mod (id ...) (id2 ...))) - (begin - (require (for-label (except-in mod id ...))) - (provide (for-label (except-out (all-from-out mod) id2 ...))))] - [(_ mod) (begin - (require (for-label mod)) - (provide (for-label (all-from-out mod))))] - [(_ mod ...) (begin (bounce-for-label mod) ...)])) +(define-syntax bounce-for-label + (syntax-rules (all-except) + [(_ (all-except mod (id ...) (id2 ...))) + (begin (require (for-label (except-in mod id ...))) + (provide (for-label (except-out (all-from-out mod) id2 ...))))] + [(_ mod) (begin (require (for-label mod)) + (provide (for-label (all-from-out mod))))] + [(_ mod ...) (begin (bounce-for-label mod) ...)])) - (bounce-for-label (all-except scheme (link) ()) - scribble/struct - scribble/base-render - scribble/decode - scribble/manual - scribble/scheme - scribble/eval - scribble/bnf) +(bounce-for-label (all-except scheme (link) ()) + scribble/struct + scribble/base-render + scribble/decode + scribble/manual + scribble/scheme + scribble/eval + scribble/bnf) - (provide scribble-examples litchar/lines) +(provide scribble-examples litchar/lines) - (define (litchar/lines . strs) - (let ([strs (regexp-split #rx"\n" (apply string-append strs))]) - (if (= 1 (length strs)) - (litchar (car strs)) - (make-table - #f - (map (lambda (s) - (list (make-flow (list (make-paragraph - (if (string=? s "") - '(nbsp) ; needed for IE - (list (litchar s)))))))) - strs))))) +(define (as-flow e) + (make-flow (list (if (block? e) e (make-paragraph (list e)))))) - (define (as-flow e) - (make-flow (list (if (block? e) - e - (make-paragraph (list e)))))) +(define (litchar/lines . strs) + (let ([strs (regexp-split #rx"\n" (apply string-append strs))]) + (if (= 1 (length strs)) + (litchar (car strs)) + (make-table + #f + (map (lambda (s) ; the nbsp is needed for IE + (list (as-flow (if (string=? s "") 'nbsp (litchar s))))) + strs))))) - (define spacer (hspace 2)) +(define spacer (hspace 2)) - (define ((norm-spacing base) p) - (cond - [(and (syntax->list p) - (not (null? (syntax-e p)))) - (let loop ([e (syntax->list p)] - [line (syntax-line (car (syntax-e p)))] - [pos base] - [second #f] - [accum null]) - (cond - [(null? e) - (datum->syntax - p - (reverse accum) - (list (syntax-source p) - (syntax-line p) - base - (add1 base) - (- pos base)) - p)] - [else - (let* ([v ((norm-spacing (if (= line (syntax-line (car e))) - pos - (or second pos))) - (car e))] - [next-pos (+ (syntax-column v) (syntax-span v) 1)]) - (loop (cdr e) - (syntax-line v) - next-pos - (or second next-pos) - (cons v accum)))]))] - [else - (datum->syntax - p - (syntax-e p) - (list (syntax-source p) - (syntax-line p) - base - (add1 base) - 1) - p)])) +(define ((norm-spacing base) p) + (cond [(and (syntax->list p) (not (null? (syntax-e p)))) + (let loop ([e (syntax->list p)] + [line (syntax-line (car (syntax-e p)))] + [pos base] + [second #f] + [accum null]) + (if (null? e) + (datum->syntax + p (reverse accum) + (list (syntax-source p) (syntax-line p) base (add1 base) + (- pos base)) + p) + (let* ([v ((norm-spacing (if (= line (syntax-line (car e))) + pos + (or second pos))) + (car e))] + [next-pos (+ (syntax-column v) (syntax-span v) 1)]) + (loop (cdr e) + (syntax-line v) + next-pos + (or second next-pos) + (cons v accum)))))] + [else (datum->syntax + p (syntax-e p) + (list (syntax-source p) (syntax-line p) base (add1 base) 1) + p)])) - (define (scribble-examples . lines) - (define reads-as (make-paragraph (list spacer "reads as" spacer))) - (let* ([lines (apply string-append lines)] - [p (open-input-string lines)]) - (port-count-lines! p) - (let loop ([r '()] [newlines? #f]) - (regexp-match? #px#"^[[:space:]]*" p) - (let* ([p1 (file-position p)] - [stx (scribble:read-syntax #f p)] - [p2 (file-position p)]) - (if (not (eof-object? stx)) - (let ([str (substring lines p1 p2)]) - (loop (cons (list str stx) r) - (or newlines? (regexp-match? #rx#"\n" str)))) - (let* ([r (reverse r)] - [r (if newlines? - (cdr (apply append (map (lambda (x) (list #f x)) r))) - r)]) - (make-table - #f - (map (lambda (x) - (let ([@expr (if x (litchar/lines (car x)) "")] - [sexpr (if x - (scheme:to-paragraph - ((norm-spacing 0) (cadr x))) - "")] - [reads-as (if x reads-as "")]) - (map as-flow (list spacer @expr reads-as sexpr)))) - r))))))))) +(define (scribble-examples . lines) + (define reads-as (make-paragraph (list spacer "reads as" spacer))) + (let* ([lines (apply string-append lines)] + [p (open-input-string lines)]) + (port-count-lines! p) + (let loop ([r '()] [newlines? #f]) + (regexp-match? #px#"^[[:space:]]*" p) + (let* ([p1 (file-position p)] + [stx (scribble:read-syntax #f p)] + [p2 (file-position p)]) + (if (not (eof-object? stx)) + (let ([str (substring lines p1 p2)]) + (loop (cons (list str stx) r) + (or newlines? (regexp-match? #rx#"\n" str)))) + (let* ([r (reverse r)] + [r (if newlines? + (cdr (apply append (map (lambda (x) (list #f x)) r))) + r)]) + (make-table + #f + (map (lambda (x) + (let ([@expr (if x (litchar/lines (car x)) "")] + [sexpr (if x + (scheme:to-paragraph + ((norm-spacing 0) (cadr x))) + "")] + [reads-as (if x reads-as "")]) + (map as-flow (list spacer @expr reads-as sexpr)))) + r)))))))) + +;; stuff for the preprocessor examples + +(require scheme/list (for-syntax scheme/base scheme/list)) + +(define max-textsample-width 45) + +(define (textsample-verbatim-boxes line in-text out-text more) + (define (split str) (regexp-split #rx"\n" str)) + (define strs1 (split in-text)) + (define strs2 (split out-text)) + (define strsm (map (compose split cdr) more)) + (define (str->elts str) + (let ([spaces (regexp-match-positions #rx"(?:^| ) +" str)]) + (if spaces + (list* (substring str 0 (caar spaces)) + (hspace (- (cdar spaces) (caar spaces))) + (str->elts (substring str (cdar spaces)))) + (list (make-element 'tt (list str)))))) + (define (make-line str) + (if (equal? str "") + ;;FIXME: this works in html, but in latex it creates a redundant newline + (list (as-flow (make-element 'newline '()))) + (list (as-flow (make-element 'tt (str->elts str)))))) + (define (small-attr attr) + (make-with-attributes attr '([style . "font-size: 82%;"]))) + (define (make-box strs) + (make-table (small-attr 'boxed) (map make-line strs))) + (define filenames (map car more)) + (define indent (let ([d (- max-textsample-width + (for*/fold ([m 0]) + ([s (in-list (cons strs1 strsm))] + [s (in-list s)]) + (max m (string-length s))))]) + (if (negative? d) + (error 'textsample-verbatim-boxes + "left box too wide for sample at line ~s" line) + (make-element 'tt (list (hspace d)))))) + ;; Note: the font-size property is reset for every table, so we need it + ;; everywhere there's text, and they don't accumulate for nested tables + (values + (make-table (make-with-attributes + '([alignment right left] [valignment top top]) + '()) + (cons (list (as-flow (make-table (small-attr #f) + (list (list (as-flow indent))))) + (as-flow (make-box strs1))) + (map (lambda (file strs) + (let* ([file (make-element 'tt (list file ":" 'nbsp))] + [file (list (make-element 'italic (list file)))]) + (list (as-flow (make-element '(bg-color 232 232 255) file)) + (as-flow (make-box strs))))) + filenames strsm))) + (make-box strs2))) + +(define (textsample line in-text out-text more) + (define-values (box1 box2) + (textsample-verbatim-boxes line in-text out-text more)) + (make-table '([alignment left left left] [valignment center center center]) + (list (map as-flow (list box1 (make-paragraph '(nbsp rarr nbsp)) box2))))) + +(define-for-syntax tests-ids #f) + +(provide initialize-tests) +(define-syntax (initialize-tests stx) + (set! tests-ids (map (lambda (x) (datum->syntax stx x stx)) + '(tests add-to-tests))) + (with-syntax ([(tests add-to-tests) tests-ids]) + #'(begin (provide tests) + (define-values (tests add-to-tests) + (let ([l '()]) + (values (lambda () (reverse l)) + (lambda (x) (set! l (cons x l))))))))) + +(provide example) +(define-syntax (example stx) + (define sep-rx #px"^---[*]{3}---(?: +(.*))?$") + (define file-rx #rx"^[a-z0-9_.+-]+$") + (define-values (body hidden?) + (syntax-case stx () + [(_ #:hidden x ...) (values #'(x ...) #t)] + [(_ x ...) (values #'(x ...) #f)])) + (let loop ([xs body] [text '(#f)] [texts '()]) + (syntax-case xs () + [("\n" sep "\n" . xs) + (and (string? (syntax-e #'sep)) (regexp-match? sep-rx (syntax-e #'sep))) + (let ([m (cond [(regexp-match sep-rx (syntax-e #'sep)) => cadr] + [else #f])]) + (if (and m (not (regexp-match? file-rx m))) + (raise-syntax-error #f "bad filename specified" stx #'sep) + (loop #'xs + (list (and m (datum->syntax #'sep m #'sep #'sep))) + (cons (reverse text) texts))))] + [(x . xs) (loop #'xs (cons #'x text) texts)] + [() (let ([texts (reverse (cons (reverse text) texts))] + [line (syntax-line stx)]) + (define-values (files i/o) (partition car texts)) + (unless ((length i/o) . = . 2) + (raise-syntax-error + 'example "need at least an input and an output block" stx)) + (with-syntax ([line line] + [((in ...) (out ...)) (map cdr i/o)] + [((file text ...) ...) files] + [add-to-tests (cadr tests-ids)]) + (quasisyntax/loc stx + (let* ([in-text (string-append in ...)] + [out-text (string-append out ...)] + [more (list (cons file (string-append text ...)) ...)]) + (add-to-tests (list line in-text out-text more)) + #,(if hidden? #'"" + #'(textsample line in-text out-text more))))))] + [_ (raise-syntax-error #f "no separator found in example text")]))) diff --git a/collects/sirmail/sendr.ss b/collects/sirmail/sendr.ss index 3f648394e6..fa7e7f8c8d 100644 --- a/collects/sirmail/sendr.ss +++ b/collects/sirmail/sendr.ss @@ -6,6 +6,7 @@ (require scheme/tcp scheme/unit scheme/class + scheme/string mred/mred-sig framework) @@ -133,12 +134,34 @@ ;; `body-lines' is a list of strings and byte strings ;; `enclosures' is a list of `enclosure' structs (define (enclose header body-lines enclosures) + (define qp-body-lines? + (ormap (lambda (l) + (or ((string-length l) . > . 1000) + (regexp-match? #rx"[^\0-\177]" l))) + body-lines)) + (define (encode-body-lines) + (if qp-body-lines? + (map + bytes->string/utf-8 + (regexp-split #rx"\r\n" + (qp-encode (string->bytes/utf-8 + (string-join body-lines "\r\n"))))) + body-lines)) + (define (add-body-encoding-headers header) + (insert-field + "Content-Type" + "text/plain; charset=UTF-8" + (insert-field + "Content-Transfer-Encoding" + (if qp-body-lines? "quoted-printable" "7bit") + header))) (if (null? enclosures) (values (insert-field - "Content-Type" - "text/plain; charset=UTF-8" - header) - body-lines) + "MIME-Version" + "1.0" + (add-body-encoding-headers + header)) + (encode-body-lines)) (let* ([enclosure-datas (map (lambda (e) ((enclosure-data-thunk e))) enclosures)] [boundary @@ -175,28 +198,23 @@ "This is a multi-part message in MIME format." (format "--~a" boundary)) (header->lines - (insert-field - "Content-Type" - "text/plain; charset=UTF-8" - (insert-field - "Content-Transfer-Encoding" - "7bit" - empty-header))) - body-lines - (apply - append - (map - (lambda (enc data) - (cons - (format "--~a" boundary) - (append - (header->lines - (enclosure-subheader enc)) - data))) - enclosures enclosure-datas)) - (list - (format "--~a--" boundary)))))))) - + (add-body-encoding-headers + empty-header)) + (encode-body-lines) + (apply + append + (map + (lambda (enc data) + (cons + (format "--~a" boundary) + (append + (header->lines + (enclosure-subheader enc)) + data))) + enclosures enclosure-datas)) + (list + (format "--~a--" boundary)))))))) + (define (get-enclosure-type-and-encoding filename mailer-frame auto?) (let ([types '("application/postscript" "text/plain" diff --git a/collects/srfi/1/misc.ss b/collects/srfi/1/misc.ss index 6e59b41ac3..066cacaa1e 100644 --- a/collects/srfi/1/misc.ss +++ b/collects/srfi/1/misc.ss @@ -39,16 +39,18 @@ "selector.ss" "util.ss" (only-in "fold.ss" reduce-right) - (rename-in "fold.ss" [map s:map] [for-each s:for-each])) + (rename-in "fold.ss" [map s:map] [for-each s:for-each]) + (only-in scheme/list count append*)) (provide length+ - concatenate (rename-out [concatenate concatenate!]) + (rename-out [append* concatenate] [append* concatenate!]) (rename-out [append append!]) (rename-out [reverse reverse!]) append-reverse (rename-out [append-reverse append-reverse!]) zip unzip1 unzip2 unzip3 unzip4 unzip5 count) +#; ; reprovided from scheme/list ;; count ;;;;;;;; (define (count pred list1 . lists) @@ -169,6 +171,7 @@ (set-cdr! rev-head tail) (lp next-rev rev-head))))) +#; ; reprovide scheme/list's `append*' function (define (concatenate lists) (reduce-right append '() lists)) #; ; lists are immutable (define (concatenate! lists) (reduce-right my-append! '() lists)) diff --git a/collects/srfi/38/38.ss b/collects/srfi/38/38.ss index b124d4c5bf..ce4306df4c 100644 --- a/collects/srfi/38/38.ss +++ b/collects/srfi/38/38.ss @@ -1,8 +1,14 @@ #lang scheme/base -(provide s:read s:write) +(define (write-with-shared-structure val [port (current-output-port)] [optarg #f]) + (parameterize ([print-graph #t]) (write val port))) + +(define (read-with-shared-structure [port (current-input-port)] [optarg #f]) + (parameterize ([read-accept-graph #t]) + (read port))) + +(provide write-with-shared-structure + (rename-out [write-with-shared-structure write/ss]) + read-with-shared-structure + (rename-out [read-with-shared-structure read/ss])) -(define (s:write . args) - (parameterize ([print-graph #t]) (apply write args))) -(define (s:read . args) - (parameterize ([read-accept-graph #t]) (apply read args))) diff --git a/collects/stepper/private/xml-snip-helpers.ss b/collects/stepper/private/xml-snip-helpers.ss index 8a46053c83..fb35654ce1 100644 --- a/collects/stepper/private/xml-snip-helpers.ss +++ b/collects/stepper/private/xml-snip-helpers.ss @@ -52,7 +52,7 @@ (lambda () (let* ([source-name (get-source-name editor)] [port (open-input-text-editor editor 0 'end (xml-snip-filter editor) source-name)] - [xml (read-xml port)] + [xml (parameterize ([permissive? #t]) (read-xml port))] [xexpr (parameterize ([permissive? #t]) (xml->xexpr (document-element xml)))] [clean-xexpr (if eliminate-whitespace-in-empty-tags? (eliminate-whitespace-in-empty-tags xexpr) diff --git a/collects/string-constants/french-string-constants.ss b/collects/string-constants/french-string-constants.ss index 82fa1a4a66..1a699599b5 100644 --- a/collects/string-constants/french-string-constants.ss +++ b/collects/string-constants/french-string-constants.ss @@ -191,7 +191,8 @@ (cs-status-expanding-expression "Vérificateur de syntaxe : expansion d'une expression") (cs-status-loading-docs-index "Vérificateur de syntaxe : chargement de l'index de la documentation") (cs-mouse-over-import "l'identificateur ~s est importé de ~s") - (cs-view-docs "Regarder la documentation pour ~a") + (cs-view-docs "Documentation pour ~a") + (cs-view-docs-from "~a dans ~a") ;; a completed version of the line above (cs-view-docs) is put into the first ~a and a list of modules (separated by commas) is put into the second ~a. Use check syntax and right-click on a documented variable (eg, 'require') to see this in use (cs-lexical-variable "variables lexicales") (cs-imported-variable "variables importées") @@ -200,7 +201,7 @@ (collect-button-label "Ramassage") ; de miettes (read-only "Lecture seulement") (auto-extend-selection "Autosélection") ; "Sélection auto-étendable" ? - (overwrite "Correction") ; vs Insertion ? surimpression ? + (overwrite "Écrasement") ; vs Insertion ? surimpression ? (running "en cours") (not-running "en attente") ; "en attente" ; pause ? @@ -242,6 +243,11 @@ (erase-log-directory-contents "Effacer le contenu du répertoire d'enregistrement : ~a ?") (error-erasing-log-directory "Erreur durant l'effacement du contenu du répertoire d'enregistrement.\n\n~a\n") + ;; menu items connected to the logger -- also in a button in the planet status line in the drs frame + (show-log "Montrer le journa&l") ; "journaux" ne contient pas de "l"... + (hide-log "Cacher le journa&l") + (logging-all "Tous") ;; in the logging window in drscheme, shows all logs simultaneously + ;; modes (mode-submenu-label "Modes") (scheme-mode "Mode scheme") @@ -676,6 +682,9 @@ (complete-word "Compléter le mot") ; the complete word menu item in the edit menu (no-completions "... pas de complétion connue") ; shows up in the completions menu when there are no completions (in italics) + (overwrite-mode "Mode d'écrasement") + (enable-overwrite-mode-keybindings "Raccourci clavier pour le mode d'écrasement") + (preferences-info "Configurer vos préférences.") (preferences-menu-item "Préférences...") @@ -707,18 +716,21 @@ (wrap-text-item "Replier le texte") + ;; windows menu (windows-menu-label "Fe&nêtres") (minimize "Minimiser") ;; minimize and zoom are only used under mac os x (zoom "Agrandir") ; Zoomer? (bring-frame-to-front "Amener une fenêtre au premier plan") ;;; title of dialog (bring-frame-to-front... "Amener une fenêtre au premier plan...") ;;; corresponding title of menu item (most-recent-window "Fenêtre la plus récente") + (next-tab "Onglet suivant") + (prev-tab "Onglet précédent") (view-menu-label "&Montrer") - (show-overview "Montrer le contour") - (hide-overview "Cacher le contour") - (show-module-browser "Montrer le navigateur de modules") - (hide-module-browser "Cacher le navigateur de modules") + (show-overview "Montrer le contour du &programme") + (hide-overview "Cacher le contour du &programme") + (show-module-browser "Montrer le navigateur de &modules") + (hide-module-browser "Cacher le navigateur de &modules") (help-menu-label "&Aide") (about-info "Auteurs et détails concernant ce logiciel.") @@ -783,7 +795,7 @@ ;;; file modified warning (file-has-been-modified "Ce fichier a été modifié depuis sa dernière sauvegarde. Voulez-vous écraser les modifications ?") - (overwrite-file-button-label "Ecraser") + (overwrite-file-button-label "Écraser") (definitions-modified "Le texte de la fenêtre de définition a été modifié directement sur le disque dur. Sauvegardez ou retournez à la version sur le disque.") @@ -842,7 +854,7 @@ (close-tab "Fermer l'onglet") (close-tab-amp "Fermer l'onglet") ;; like close-tab, but with an ampersand on the same letter as the one in close-menu-item - ;;; edit-menu + ;;; edit menu (split-menu-item-label "Di&viser") (collapse-menu-item-label "&Rassembler") @@ -859,10 +871,10 @@ (force-quit-menu-item-help-string "Utilise custodian-shutdown-all pour terminer toute l'évaluation courante") (limit-memory-menu-item-label "Limiter la mémoire...") (limit-memory-msg-1 "La limite prendra effet à la prochaine exécution du programme.") - (limit-memory-msg-2 "Elle doit être d'au moins 1 megaoctet.") + (limit-memory-msg-2 "Elle doit être d'au moins un megaoctet.") (limit-memory-unlimited "Illimitée") - (limit-memory-limited "Limitée") - (limit-memory-megabytes "Megaoctets") + (limit-memory-limited "Limitée à") + (limit-memory-megabytes "megaoctets") (clear-error-highlight-menu-item-label "Effacer le surlignage d'erreur") (clear-error-highlight-item-help-string "Efface le surlignage rose après une erreur") (reindent-menu-item-label "&Réindenter") @@ -996,6 +1008,7 @@ (decimal-notation-for-rationals "Utiliser la notation décimale pour les nombres rationnels") (enforce-primitives-group-box-label "Définitions initiales") (enforce-primitives-check-box-label "Interdire la redéfinition des définition initiales") + (automatically-compile? "Compiler automatiquement les fichiers source ?") ; used in the bottom left of the drscheme frame as the label ; used the popup menu from the just above; greyed out and only @@ -1033,6 +1046,7 @@ (no-language-chosen "Aucun langage sélectionné") (module-language-one-line-summary "Exécuter crée une fenêtre d'interaction dans le contexte du module, incluant le langage du module lui-même") + (module-language-auto-text "Ligne #lang automatique") ;; shows up in the details section of the module language ;;; from the `not a language language' used initially in drscheme. (must-choose-language "DrScheme ne peut pas traiter un programme avant que vous aillez sélectionné un langage.") @@ -1423,5 +1437,18 @@ (bug-track-forget "Oublier") (bug-track-forget-all "Oublier tous") + ;; planet status messages in the bottom of the drscheme window; the ~a is filled with the name of the package + (planet-downloading "PLaneT: téléchargement de ~a...") + (planet-installing "PLaneT: installation de ~a...") + (planet-finished "PLaneT: ~a à jour.") + (planet-no-status "PLaneT") ;; this can happen when there is status shown in a different and then the user switches to a tab where planet hasn't been used + + ;; string normalization. To see this, paste some text with a ligature into DrScheme + ;; the first three strings are in the dialog that appears. The last one is in the preferences dialog + (normalize "Normaliser") + (leave-alone "Ne pas changer") + (normalize-string-info "La chaîne de caractères à coller contient des ligatures ou des caractères non-normalisés. Normaliser la chaîne ?") + (normalize-string-preference "Normaliser les chaînes de caractères durant le collage") + (ask-about-normalizing-strings "Demander à propos de la normalisation des chaînes de caractères") ); "aâàbcçdeéêèëfghiîïjklmnoôpqrstuûùüvwxyz" diff --git a/collects/stxclass/main.ss b/collects/stxclass/main.ss index f55c6ba21a..ba5bbc094c 100644 --- a/collects/stxclass/main.ss +++ b/collects/stxclass/main.ss @@ -4,10 +4,8 @@ "private/lib.ss") (provide define-syntax-class - define-basic-syntax-class - define-basic-syntax-class* pattern - basic-syntax-class + ~and ~or ...* diff --git a/collects/stxclass/private/codegen.ss b/collects/stxclass/private/codegen.ss index 81727b614f..0798fafc58 100644 --- a/collects/stxclass/private/codegen.ss +++ b/collects/stxclass/private/codegen.ss @@ -23,25 +23,22 @@ ;; Takes a list of the relevant attrs; order is significant! ;; Returns either fail or a list having length same as 'relsattrs' (define (parse:rhs rhs relsattrs args) - (cond [(rhs:union? rhs) - (with-syntax ([(arg ...) args]) - #`(lambda (x arg ...) - (define (fail-rhs x expected frontier frontier-stx) - #,(if (rhs-transparent? rhs) - #`(make-failed x expected frontier frontier-stx) - #'#f)) - (syntax-parameterize ((this-syntax (make-rename-transformer #'x))) - #,(let ([pks (rhs->pks rhs relsattrs #'x)]) - (unless (pair? pks) - (wrong-syntax (rhs-orig-stx rhs) - "syntax class has no variants")) - (parse:pks (list #'x) - (list (empty-frontier #'x)) - #'fail-rhs - (list #f) - pks)))))] - [(rhs:basic? rhs) - (rhs:basic-parser rhs)])) + (with-syntax ([(arg ...) args]) + #`(lambda (x arg ...) + (define (fail-rhs x expected frontier frontier-stx) + #,(if (rhs-transparent? rhs) + #`(make-failed x expected frontier frontier-stx) + #'#f)) + (syntax-parameterize ((this-syntax (make-rename-transformer #'x))) + #,(let ([pks (rhs->pks rhs relsattrs #'x)]) + (unless (pair? pks) + (wrong-syntax (rhs-ostx rhs) + "syntax class has no variants")) + (parse:pks (list #'x) + (list (empty-frontier #'x)) + #'fail-rhs + (list #f) + pks)))))) ;; parse:clauses : stx identifier identifier -> stx (define (parse:clauses stx var phi) @@ -82,15 +79,15 @@ ;; rhs->pks : RHS (listof SAttr) identifier -> (listof PK) (define (rhs->pks rhs relsattrs main-var) (match rhs - [(struct rhs:union (orig-stx attrs transparent? description patterns)) + [(struct rhs:union (_ attrs transparent? description patterns)) (for*/list ([rhs patterns] [pk (rhs-pattern->pks rhs relsattrs main-var)]) pk)])) ;; rhs-pattern->pks : RHS (listof SAttr) identifier -> (listof PK) (define (rhs-pattern->pks rhs relsattrs main-var) (match rhs - [(struct rhs:pattern (orig-stx attrs pattern decls remap sides)) - (parameterize ((current-syntax-context orig-stx)) + [(struct rhs:pattern (ostx attrs pattern decls remap sides)) + (parameterize ((current-syntax-context ostx)) (define iattrs (append-attrs (cons (pattern-attrs pattern) @@ -311,7 +308,7 @@ Conventions: ;; parse:gseq:and : pat:and (listof Pattern) stx ;; -> stx (define (parse:group:and vars fcs phi ds and-pattern rest-patterns k) - (match-define (struct pat:and (orig-stx attrs depth description patterns)) + (match-define (struct pat:and (_ _ _ description patterns)) and-pattern) ;; FIXME: handle description (let ([var0-copies (for/list ([p patterns]) (car vars))] @@ -326,7 +323,7 @@ Conventions: ;; parse:compound:gseq : pat:gseq (listof Pattern) stx ;; -> stx (define (parse:group:gseq vars fcs phi ds gseq-pattern rest-patterns k) - (match-define (struct pat:gseq (orig-stx attrs depth heads tail)) gseq-pattern) + (match-define (struct pat:gseq (ostx attrs depth heads tail)) gseq-pattern) (define xvar (generate-temporary 'x)) (define head-lengths (for/list ([head heads]) (length (head-ps head)))) (define head-attrss (for/list ([head heads]) (flatten-attrs* (head-attrs head)))) @@ -348,7 +345,7 @@ Conventions: (map attr-name head-attrs))) (define completed-heads (for/list ([head heads]) - (complete-heads-pattern head xvar (add1 depth) orig-stx))) + (complete-heads-pattern head xvar (add1 depth) ostx))) (define hid-argss (map generate-temporaries head-idss)) (define hid-args (apply append hid-argss)) (define mins (map head-min heads)) @@ -436,12 +433,12 @@ Conventions: [rep 0] ...) (parse-loop var0 hid ... ... rep ... #,phi)))))) -;; complete-heads-patterns : Head identifier number stx -> Pattern -(define (complete-heads-pattern head rest-var depth seq-orig-stx) +;; complete-heads-patterns : Head identifier number -> Pattern +(define (complete-heads-pattern head rest-var depth seq-ostx) (define (loop ps pat) (if (pair? ps) (make pat:compound - (cons (pattern-orig-stx (car ps)) (pattern-orig-stx pat)) + (cons (pattern-ostx (car ps)) (pattern-ostx pat)) (append (pattern-attrs (car ps)) (pattern-attrs pat)) depth pairK @@ -449,7 +446,7 @@ Conventions: pat)) (define base (make pat:id - seq-orig-stx + seq-ostx (list (make-attr rest-var depth null)) depth rest-var #f null)) (loop (head-ps head) base)) @@ -493,8 +490,8 @@ Conventions: (let ([result (not (pattern-intersects? p1 p2))]) (when #f ;; result (printf "commutes!\n ~s\n & ~s\n" - (syntax->datum (pattern-orig-stx p1)) - (syntax->datum (pattern-orig-stx p2)))) + (syntax->datum (pattern-ostx p1)) + (syntax->datum (pattern-ostx p2)))) result)) (define (pattern-intersects? p1 p2) @@ -636,8 +633,7 @@ Conventions: (define (shift-pks:compound pks) (define (shift-pk pk0) (match pk0 - [(struct pk ((cons (struct pat:compound (orig-stx attrs depth kind patterns)) - rest-ps) + [(struct pk ((cons (struct pat:compound (_ _ _ _ patterns)) rest-ps) k)) (make-pk (append patterns rest-ps) k)])) (map shift-pk pks)) diff --git a/collects/stxclass/private/rep-data.ss b/collects/stxclass/private/rep-data.ss index 6de85b445f..7e06a6e34a 100644 --- a/collects/stxclass/private/rep-data.ss +++ b/collects/stxclass/private/rep-data.ss @@ -8,7 +8,6 @@ (struct-out attr) (struct-out rhs) (struct-out rhs:union) - (struct-out rhs:basic) (struct-out rhs:pattern) (struct-out pattern) (struct-out pat:id) @@ -34,22 +33,50 @@ #:transparent) ;; RHSBase is stx (listof SAttr) boolean stx/#f -(define-struct rhs (orig-stx attrs transparent? description) +(define-struct rhs (ostx attrs transparent? description) #:transparent) ;; A RHS is one of ;; (make-rhs:union (listof RHS)) -;; (make-rhs:basic stx) (define-struct (rhs:union rhs) (patterns) #:transparent) -(define-struct (rhs:basic rhs) (parser) - #:transparent) ;; An RHSPattern is ;; (make-rhs:pattern stx (listof SAttr) Pattern Env Env (listof SideClause)) -(define-struct rhs:pattern (stx attrs pattern decls remap whens) +(define-struct rhs:pattern (stx attrs pattern decls remap sides) #:transparent) +#| + +NOT YET ... + +;; A Pattern is +;; (make-pattern (listof IAttr) PCtx (listof id) string/#f Descriminator) +(define-struct pattern (attrs ctx names description descrim) #:transparent) + +;; A PatternContext (PCtx) is +;; (make-pctx stx nat (listof IAttr) (listof IAttr)) +(define-struct pctx (ostx depth env outer-env) #:transparent) + +;; A Descriminator is one of +;; (make-d:any) +;; (make-d:stxclass SC (listof stx)) +;; (make-d:datum datum) +;; (make-d:literal id) +;; (make-d:gseq (listof Head) Pattern) +;; (make-d:and (listof Pattern)) +;; (make-d:orseq (listof Head)) +;; (make-d:compound Kind (listof Pattern)) +(define-struct d:any () #:transparent) +(define-struct d:stxclass (stxclass args) #:transparent) +(define-struct d:datum (datum) #:transparent) +(define-struct d:literal (literal) #:transparent) +(define-struct d:gseq (heads tail) #:transparent) +(define-struct d:and (subpatterns) #:transparent) +(define-struct d:orseq (heads) #:transparent) +(define-struct d:compound (kind patterns) #:transparent) +|# + ;; A Pattern is one of ;; (make-pat:id identifier SC/#f (listof stx)) ;; (make-pat:datum datum) @@ -59,7 +86,7 @@ ;; (make-pat:and string/#f (listof Pattern)) ;; (make-pat:compound Kind (listof Pattern)) ;; when = stx (listof IAttr) number -(define-struct pattern (orig-stx attrs depth) #:transparent) +(define-struct pattern (ostx attrs depth) #:transparent) (define-struct (pat:id pattern) (name stxclass args) #:transparent) (define-struct (pat:datum pattern) (datum) #:transparent) (define-struct (pat:literal pattern) (literal) #:transparent) @@ -72,8 +99,9 @@ (define-struct kind (predicate selectors frontier-procs) #:transparent) ;; A Head is -;; (make-head stx (listof IAttr) nat (listof Pattern) nat/f nat/f boolean id/#f stx/#f) -(define-struct head (orig-stx attrs depth ps min max as-list?) #:transparent) +;; (make-head stx (listof IAttr) nat (listof Pattern) +;; nat/f nat/f boolean id/#f stx/#f) +(define-struct head (ostx attrs depth ps min max as-list?) #:transparent) ;; A SideClause is one of ;; (make-clause:with pattern stx) diff --git a/collects/stxclass/private/rep.ss b/collects/stxclass/private/rep.ss index dd96ade8d5..d604bae802 100644 --- a/collects/stxclass/private/rep.ss +++ b/collects/stxclass/private/rep.ss @@ -102,30 +102,6 @@ (define transparent? (and trans0 #t)) (define attributes (and attrs0 (caddr attrs0))) - (define (parse-rhs*-basic rhss) - (syntax-case rhss (basic-syntax-class) - [((basic-syntax-class . rest)) - (let-values ([(basic-chunks rest) - (chunk-kw-seq/no-dups #'rest basic-rhs-directive-table - #:context (stx-car rhss))]) - (syntax-case rest () - [(parser-expr) - (make rhs:basic ctx - (or attributes null) - transparent? - description - (if (assq '#:transforming basic-chunks) - #'parser-expr - #`(let ([parser parser-expr]) - (lambda (x . args) - (let ([result (apply parser x args)]) - (if (ok? result) - (cons x result) - result))))))] - [_ - (wrong-syntax (stx-car rhss) - "expected parser expression")]))])) - (define (parse-rhs*-patterns rest) (define (gather-patterns stx) (syntax-case stx (pattern) @@ -145,11 +121,7 @@ description patterns))) - (syntax-case rest (pattern basic-syntax-class) - [((basic-syntax-class . _)) - (parse-rhs*-basic rest)] - [_ - (parse-rhs*-patterns rest)])) + (parse-rhs*-patterns rest)) ;; parse-rhs-pattern : stx boolean boolean (listof id+id) -> RHS (define (parse-rhs-pattern stx allow-unbound? literals) @@ -278,8 +250,8 @@ (define (pattern->head p) (match p - [(struct pattern (orig-stx iattrs depth)) - (make head orig-stx iattrs depth (list p) #f #f #t)])) + [(struct pattern (ostx iattrs depth)) + (make head ostx iattrs depth (list p) #f #f #t)])) (define (parse-heads stx decls enclosing-depth) (syntax-case stx () @@ -468,10 +440,6 @@ (list '#:transparent) (list '#:attributes check-attr-arity-list))) -;; basic-rhs-directive-table -(define basic-rhs-directive-table - (list (list '#:transforming))) - ;; pattern-directive-table (define pattern-directive-table (list (list '#:declare check-id values) diff --git a/collects/stxclass/private/runtime.ss b/collects/stxclass/private/runtime.ss index 22a3bdaaad..ba9ecebdee 100644 --- a/collects/stxclass/private/runtime.ss +++ b/collects/stxclass/private/runtime.ss @@ -8,7 +8,6 @@ (for-syntax "rep-data.ss") (for-syntax "../util/error.ss")) (provide pattern - basic-syntax-class ~and ~or ...* @@ -44,7 +43,6 @@ (raise-syntax-error #f "keyword used out of context" stx)))) (define-keyword pattern) -(define-keyword basic-syntax-class) (define-keyword ~and) (define-keyword ~or) (define-keyword ...*) diff --git a/collects/stxclass/private/sc.ss b/collects/stxclass/private/sc.ss index 1f9e10b039..453d8e63fb 100644 --- a/collects/stxclass/private/sc.ss +++ b/collects/stxclass/private/sc.ss @@ -12,8 +12,6 @@ "runtime.ss") (provide define-syntax-class - define-basic-syntax-class - define-basic-syntax-class* parse-sc attrs-of @@ -22,7 +20,6 @@ with-patterns pattern - basic-syntax-class ~and ~or ...* @@ -92,39 +89,6 @@ (syntax/loc stx (define-syntax-class (name) . rhss))])) -(define-syntax define-basic-syntax-class - (syntax-rules () - [(define-basic-syntax-class (name arg ...) - ([attr-name attr-depth] ...) - parser-expr) - (define-basic-syntax-class* (name arg ...) - ([attr-name attr-depth] ...) - (let ([name parser-expr]) - (let ([name - (lambda (x arg ...) - (let ([r (name x arg ...)]) - (if (ok? r) - (cons x r) - r)))]) - name)))] - [(define-basic-syntax-class name - ([attr-name attr-depth] ...) - parser-expr) - (define-basic-syntax-class (name) - ([attr-name attr-depth] ...) - parser-expr)])) - -(define-syntax define-basic-syntax-class* - (syntax-rules () - [(define-basic-syntax-class* (name arg ...) - ([attr-name attr-depth] ...) - parser-expr) - (define-syntax-class (name arg ...) - #:attributes ([attr-name attr-depth] ...) - (basic-syntax-class - #:transforming - (let ([name parser-expr]) name)))])) - (define-syntax (rhs->parser+description stx) (syntax-case stx () [(rhs->parser+description name rhss (arg ...) ctx) diff --git a/collects/syntax/scribblings/strip-context.scrbl b/collects/syntax/scribblings/strip-context.scrbl index 0953ef514c..41e38b7314 100644 --- a/collects/syntax/scribblings/strip-context.scrbl +++ b/collects/syntax/scribblings/strip-context.scrbl @@ -2,7 +2,7 @@ @(require "common.ss" (for-label syntax/strip-context)) -@title[#:tag "strip-context"]{Stripping Lexical Context} +@title[#:tag "strip-context"]{Replacing Lexical Context} @defmodule[syntax/strip-context] @@ -10,3 +10,9 @@ Removes all lexical context from @scheme[stx], preserving source-location information and properties.} + +@defproc[(replace-context [ctx-stx (or/c syntax? #f)] [stx syntax?]) syntax?]{ + +Uses the lexical context of @scheme[ctx-stx] to replace the lexical +context of all parts of @scheme[stx], preserving source-location +information and properties of @scheme[stx].} diff --git a/collects/syntax/strip-context.ss b/collects/syntax/strip-context.ss index 779b7f5342..20d71747ef 100644 --- a/collects/syntax/strip-context.ss +++ b/collects/syntax/strip-context.ss @@ -1,23 +1,27 @@ #lang scheme/base -(provide strip-context) +(provide strip-context + replace-context) (define (strip-context e) + (replace-context #f e)) + +(define (replace-context ctx e) (cond [(syntax? e) - (datum->syntax #f - (strip-context (syntax-e e)) + (datum->syntax ctx + (replace-context ctx (syntax-e e)) e e)] - [(pair? e) (cons (strip-context (car e)) - (strip-context (cdr e)))] + [(pair? e) (cons (replace-context ctx (car e)) + (replace-context ctx (cdr e)))] [(vector? e) (list->vector - (map strip-context + (map (lambda (e) (replace-context ctx e)) (vector->list e)))] - [(box? e) (box (strip-context (unbox e)))] + [(box? e) (box (replace-context ctx (unbox e)))] [(prefab-struct-key e) => (lambda (k) (apply make-prefab-struct k - (strip-context (cdr (vector->list (struct->vector e))))))] + (replace-context ctx (cdr (vector->list (struct->vector e))))))] [else e])) diff --git a/collects/teachpack/2htdp/scribblings/universe.scrbl b/collects/teachpack/2htdp/scribblings/universe.scrbl index 25b41981d7..e8da05e248 100644 --- a/collects/teachpack/2htdp/scribblings/universe.scrbl +++ b/collects/teachpack/2htdp/scribblings/universe.scrbl @@ -940,7 +940,7 @@ for universe programs. For example: } @item{Each event handler produces a @emph{bundle}, which is a structure - that contains the list of @emph{iworld}s to keep track of; the + that contains the list of @emph{iworld}s that the universe must track; the @tech{server}'s remaining state; and a list of mails to other worlds: @@ -948,8 +948,11 @@ for universe programs. For example: determines whether @scheme[x] is a @emph{bundle}.} @defproc[(make-bundle [low (listof iworld?)] [state any/c] [mails (listof mail?)]) bundle?]{ - creates a @emph{bundle} from a list of iworlds, a piece of data that represents a server - state, and a list of mails.} + creates a @emph{bundle} from a list of iworlds, a piece of data that + represents a server state, and a list of mails.} + +If an event handler returns a bundle with an empty list of worlds, the +universe server is restarted in the initial state. A @emph{mail} represents a message from an event handler to a world. The teachpack provides only a predicate and a constructor for these structures: @@ -960,7 +963,6 @@ teachpack provides only a predicate and a constructor for these structures: @defproc[(make-mail [to iworld?] [content sexp?]) mail?]{ creates a @emph{mail} from a @emph{iworld} and an @tech{S-expression}.} } - ] @; ----------------------------------------------------------------------------- @@ -1039,7 +1041,6 @@ The mandatory clauses of a @scheme[universe] server description are @scheme[w] is guaranteed to be on the list @scheme[low]. } }] - All proper event handlers produce a @emph{bundle}. The list of worlds in this @emph{bundle} becomes the server's list of worlds, meaning that only the server listens only to messages from "approved" worlds. The state in diff --git a/collects/teachpack/deinprogramm/scribblings/deinprogramm.scrbl b/collects/teachpack/deinprogramm/scribblings/deinprogramm.scrbl deleted file mode 100644 index ff415fcf71..0000000000 --- a/collects/teachpack/deinprogramm/scribblings/deinprogramm.scrbl +++ /dev/null @@ -1,18 +0,0 @@ -#lang scribble/doc - -@(require scribble/manual - (for-label scheme)) - -@title[#:style '(toc) #:tag "deinprogramm"]{DeinProgramm-Teachpacks} - -Note: This is documentation for the teachpacks that go with the German -textbook @italic{@link["http://www.deinprogramm.de/dmda/"]{Die Macht -der Abstraktion}}. - -@table-of-contents[] - -@include-section["image.scrbl"] -@include-section["world.scrbl"] -@include-section["turtle.scrbl"] -@include-section["sound.scrbl"] -@include-section["line3d.scrbl"] diff --git a/collects/teachpack/deinprogramm/scribblings/info.ss b/collects/teachpack/deinprogramm/scribblings/info.ss deleted file mode 100644 index 3bae7dc50b..0000000000 --- a/collects/teachpack/deinprogramm/scribblings/info.ss +++ /dev/null @@ -1,3 +0,0 @@ -#lang setup/infotab - -(define scribblings '(("deinprogramm.scrbl" (multi-page) (library -10)))) diff --git a/collects/test-engine/info.ss b/collects/test-engine/info.ss index b3d8151bf4..038c6489e6 100644 --- a/collects/test-engine/info.ss +++ b/collects/test-engine/info.ss @@ -2,3 +2,5 @@ (define tools (list (list "test-tool.scm"))) (define tool-names '("Test Engine")) + +(define scribblings '(("test-engine.scrbl" () (tool-library)))) \ No newline at end of file diff --git a/collects/test-engine/scheme-tests.ss b/collects/test-engine/scheme-tests.ss index 67e0090568..89e72076dd 100644 --- a/collects/test-engine/scheme-tests.ss +++ b/collects/test-engine/scheme-tests.ss @@ -17,10 +17,14 @@ (define INEXACT-NUMBERS-FMT "check-expect cannot compare inexact numbers. Try (check-within test ~a range).") +(define FUNCTION-FMT + "check-expect cannot compare functions.") (define CHECK-ERROR-STR-FMT "check-error requires a string for the second argument, representing the expected error message. Given ~s") (define CHECK-WITHIN-INEXACT-FMT "check-within requires an inexact number for the range. ~a is not inexact.") +(define CHECK-WITHIN-FUNCTION-FMT + "check-within cannot compare functions.") (define-for-syntax CHECK-EXPECT-STR "check-expect requires two expressions. Try (check-expect test expected).") @@ -113,7 +117,8 @@ ;; check-values-expected: (-> scheme-val) scheme-val src -> void (define (check-values-expected test actual src test-info) (error-check (lambda (v) (if (number? v) (exact? v) #t)) - actual INEXACT-NUMBERS-FMT) + actual INEXACT-NUMBERS-FMT #t) + (error-check (lambda (v) (not (procedure? v))) actual FUNCTION-FMT #f) (send (send test-info get-info) add-check) (run-and-check (lambda (v1 v2 _) (beginner-equal? v1 v2)) (lambda (src v1 v2 _) (make-unequal src v1 v2)) @@ -130,7 +135,8 @@ [_ (raise-syntax-error 'check-within CHECK-WITHIN-STR stx)])) (define (check-values-within test actual within src test-info) - (error-check number? within CHECK-WITHIN-INEXACT-FMT) + (error-check number? within CHECK-WITHIN-INEXACT-FMT #t) + (error-check (lambda (v) (not (procedure? v))) actual CHECK-WITHIN-FUNCTION-FMT #f) (send (send test-info get-info) add-check) (run-and-check beginner-equal~? make-outofrange test actual within src test-info @@ -147,7 +153,7 @@ [_ (raise-syntax-error 'check-error CHECK-ERROR-STR stx)])) (define (check-values-error test error src test-info) - (error-check string? error CHECK-ERROR-STR-FMT) + (error-check string? error CHECK-ERROR-STR-FMT #t) (send (send test-info get-info) add-check) (let ([result (with-handlers ([exn? (lambda (e) @@ -165,9 +171,9 @@ #t))) -(define (error-check pred? actual fmt) +(define (error-check pred? actual fmt fmt-act?) (unless (pred? actual) - (raise (make-exn:fail:contract (format fmt actual) + (raise (make-exn:fail:contract (if fmt-act? (format fmt actual) fmt) (current-continuation-marks))))) diff --git a/collects/test-engine/test-engine.scrbl b/collects/test-engine/test-engine.scrbl new file mode 100644 index 0000000000..80d332a5cb --- /dev/null +++ b/collects/test-engine/test-engine.scrbl @@ -0,0 +1,86 @@ +#lang scribble/doc +@(require scribble/manual + (for-label scheme/base + test-engine/scheme-tests + (prefix-in gui: test-engine/scheme-gui))) + +@title{Test Support} + +@author["Kathryn Gray"] + +@table-of-contents[] + +@; ---------------------------------------------------------------------- + +@section{Using Check Forms} + +@defmodule[test-engine/scheme-tests] + +This module provides test forms for use in Scheme programs, as well +as parameters to configure the behavior of test reports. + +Each check form may only occur at the top-level or within the +definitions of a local declaration; results are collected and reported +by the test function. + +@defproc[(check-expect (test any/c) (expected any/c)) void?]{ + +Accepts two value-producing expressions and structurally compares the +resulting values. + +It is an error to produce a function value or an inexact number.} + + +@defproc[(check-within (test any/c) (expected any/c) (delta number?)) void?]{ + +Like @scheme[check-expect], but with an extra expression that produces +a number delta. Every number in the first expression must be within +delta of the cooresponding number in the second expression. + +It is an error to produce a function value.} + + +@defproc[(check-error (test any/c) (msg string?)) void?]{ + +Checks that evaluating the first expression signals an error, where +the error message matches the string.} + +@defproc[(test) void?]{ + +Runs all of the tests specified by check forms in the current module +and reports the results. When using the gui module, the results are +provided in a separate window, otherwise the results are printed to +the current output port.} + +@defparam[test-format format (any/c . -> . string?)]{ + +A parameter that stores the formatting function for the values tested +by the check forms.} + + +@defboolparam[test-silence silence?]{ + +A parameter that stores a boolean, defaults to #f, that can be used to +suppress the printed summary from test.} + + +@defboolparam[test-execute execute?]{ + +A parameter that stores a boolean, defaults to #t, that can be used to +suppress evaluation of test expressions. +} + +@section{GUI Interface} + +@defmodule[test-engine/scheme-gui] + +@; FIXME: need to actually list the bindings here, so they're found in +@; the index + +This module requires MrEd and produces an independent window when +displaying test results. It provides the same bindings as +@scheme[test-engine/scheme-tests]. + +@section{Integrating languages with Test Engine} + +@italic{(To be written.)} diff --git a/collects/tests/deinprogramm/contract.ss b/collects/tests/deinprogramm/contract.ss new file mode 100644 index 0000000000..f450d55a38 --- /dev/null +++ b/collects/tests/deinprogramm/contract.ss @@ -0,0 +1,264 @@ +#lang scheme/base + +(provide all-contract-tests) + +(require (planet schematics/schemeunit:3) + deinprogramm/contract/contract + deinprogramm/contract/contract-syntax) + +(require scheme/promise) + +(define integer (make-predicate-contract 'integer integer? 'integer-marker)) +(define boolean (make-predicate-contract 'boolean boolean? 'boolean-marker)) +(define %a (make-type-variable-contract 'a 'a-marker)) +(define %b (make-type-variable-contract 'b 'b-marker)) + +(define-syntax say-no + (syntax-rules () + ((say-no ?body ...) + (let/ec exit + (call-with-contract-violation-proc + (lambda (obj contract message blame) + (exit 'no)) + (lambda () + ?body ...)))))) + +(define-syntax failed-contract + (syntax-rules () + ((say-no ?body ...) + (let/ec exit + (call-with-contract-violation-proc + (lambda (obj contract message blame) + (exit contract)) + (lambda () + ?body ...)))))) + +(define contract-tests + (test-suite + "Tests for contract combinators" + + (test-case + "flat" + (check-equal? (say-no (apply-contract integer 5)) 5) + (check-equal? (say-no (apply-contract integer "foo")) 'no)) + + (test-case + "list" + (define integer-list (make-list-contract 'integer-list integer #f)) + (check-equal? (say-no (apply-contract integer-list '(1 2 3))) + '(1 2 3)) + (check-equal? (say-no (apply-contract integer-list '#f)) + 'no) + (check-eq? (failed-contract (apply-contract integer-list '(1 #f 3))) + integer)) + + (test-case + "list-cached" + (define integer-list (make-list-contract 'integer-list integer #f)) + (define boolean-list (make-list-contract 'integer-list boolean #f)) + (define l '(1 2 3)) + (define foo "foo") + (define no '(1 #f 3)) + (define no2 '(1 #f 3)) + (define integer-list->bool (make-procedure-contract 'integer-list->bool (list integer-list) boolean 'int->bool-marker)) + + (check-equal? (say-no (apply-contract integer-list l)) + '(1 2 3)) + (check-equal? (say-no (apply-contract integer-list l)) + '(1 2 3)) + (check-equal? (say-no (apply-contract boolean-list l)) + 'no) + (check-equal? (say-no (apply-contract integer-list foo)) + 'no) + (check-equal? (say-no (apply-contract integer-list foo)) + 'no) + (check-eq? (failed-contract (apply-contract integer-list no)) + integer) + (check-eq? (failed-contract (apply-contract integer-list no)) + integer) + + (let ((proc (say-no (apply-contract integer-list->bool (lambda (l) (even? (car l))))))) + (check-equal? (say-no (proc no)) 'no) + (check-equal? (say-no (proc no)) 'no) + (check-equal? (say-no (proc no2)) 'no) + (check-equal? (say-no (proc no2)) 'no)) + ) + + (test-case + "mixed" + (define int-or-bool (make-mixed-contract 'int-or-bool + (list integer + boolean) + 'int-or-bool-marker)) + (check-equal? (say-no (apply-contract int-or-bool #f)) + #f) + (check-equal? (say-no (apply-contract int-or-bool 17)) + 17) + (check-equal? (say-no (apply-contract int-or-bool "foo")) + 'no)) + + (test-case + "combined" + (define octet (make-combined-contract + 'octet + (list + integer + (make-predicate-contract '<256 + (delay (lambda (x) + (< x 256))) + '<256-marker) + (make-predicate-contract 'non-negative + (delay (lambda (x) + (>= x 0))) + 'non-negative-marker)) + 'octet-marker)) + (check-equal? (say-no (apply-contract octet #f)) + 'no) + (check-equal? (say-no (apply-contract octet 17)) + 17) + (check-equal? (say-no (apply-contract octet 0)) + 0) + (check-equal? (say-no (apply-contract octet -1)) + 'no) + (check-equal? (say-no (apply-contract octet 255)) + 255) + (check-equal? (say-no (apply-contract octet 256)) + 'no) + (check-equal? (say-no (apply-contract octet "foo")) + 'no)) + + (test-case + "case" + (define foo-or-bar (make-case-contract 'foo-or-bar '("foo" "bar") 'foo-or-bar-marker)) + (check-equal? (say-no (apply-contract foo-or-bar #f)) + 'no) + (check-equal? (say-no (apply-contract foo-or-bar "foo")) + "foo") + (check-equal? (say-no (apply-contract foo-or-bar "bar")) + "bar")) + + (test-case + "procedure" + (define int->bool (make-procedure-contract 'int->bool (list integer) boolean 'int->bool-marker)) + (check-equal? (say-no (apply-contract int->bool #f)) + 'no) + (check-equal? (say-no (apply-contract int->bool (lambda () "foo"))) + 'no) + (check-equal? (say-no (apply-contract int->bool (lambda (x y) "foo"))) + 'no) + (let ((proc (say-no (apply-contract int->bool (lambda (x) (odd? x)))))) + (check-pred procedure? proc) + (check-equal? (proc 15) #t) + (check-equal? (proc 16) #f) + (check-equal? (say-no (proc 12 15)) 'no) + (check-equal? (say-no (proc "foo")) 'no)) + (let ((proc (say-no (apply-contract int->bool (lambda (x) (+ x 1)))))) + (check-equal? (say-no (proc 12)) 'no))) + + (test-case + "type variable - simple" + (check-equal? (say-no (apply-contract %a #f)) #f) + (check-equal? (say-no (apply-contract %a 15)) 15)) + + (test-case + "type variable - list" + (define a-list (make-list-contract 'a-list %a #f)) + (check-equal? (say-no (apply-contract a-list '(1 2 3))) + '(1 2 3)) + (check-equal? (say-no (apply-contract a-list '#f)) + 'no) + (check-equal? (say-no (apply-contract a-list '(#f "foo" 5))) + '(#f "foo" 5))) + + (test-case + "apply-contract/blame" + (define int->bool (make-procedure-contract 'int->bool (list integer) boolean 'int->bool-marker)) + (let ((proc (say-no (apply-contract/blame int->bool (lambda (x) (odd? x)))))) + (check-pred procedure? proc) + (check-equal? (proc 15) #t) + (check-equal? (proc 16) #f) + (check-equal? (say-no (proc 12 15)) 'no) + (check-equal? (say-no (proc "foo")) 'no)) + (let ((proc (say-no (apply-contract/blame int->bool (lambda (x) x))))) + (call-with-contract-violation-proc + (lambda (obj contract message blame) + (check-true (syntax? blame))) + (lambda () + (proc 5))))) + )) + +(define contract-syntax-tests + (test-suite + "Tests for contract syntax" + + (test-case + "predicate" + (define-contract integer (predicate integer?)) + (check-equal? (say-no (apply-contract integer 5)) 5) + (check-equal? (say-no (apply-contract integer "foo")) 'no)) + + (test-case + "list" + (check-equal? (say-no (apply-contract (contract x (list %a)) 5)) 'no) + (check-equal? (say-no (apply-contract (contract x (list %a)) '(1 2 3))) '(1 2 3)) + (check-equal? (say-no (apply-contract (contract x (list (predicate integer?))) '(1 2 3))) '(1 2 3)) + (check-equal? (say-no (apply-contract (contract x (list (predicate integer?))) '(1 #f 3))) 'no)) + + (test-case + "mixed" + (define int-or-bool (contract (mixed integer boolean))) + (check-equal? (say-no (apply-contract int-or-bool #f)) + #f) + (check-equal? (say-no (apply-contract int-or-bool 17)) + 17) + (check-equal? (say-no (apply-contract int-or-bool "foo")) + 'no)) + + (test-case + "combined" + (define octet (contract (combined integer + (predicate (lambda (x) + (< x 256))) + (predicate (lambda (x) + (>= x 0)))))) + (check-equal? (say-no (apply-contract octet #f)) + 'no) + (check-equal? (say-no (apply-contract octet 17)) + 17) + (check-equal? (say-no (apply-contract octet 0)) + 0) + (check-equal? (say-no (apply-contract octet -1)) + 'no) + (check-equal? (say-no (apply-contract octet 255)) + 255) + (check-equal? (say-no (apply-contract octet 256)) + 'no) + (check-equal? (say-no (apply-contract octet "foo")) + 'no)) + + (test-case + "procedure" + (define int->bool (contract int->bool ((predicate integer?) -> (predicate boolean?)))) + (check-equal? (say-no (apply-contract int->bool #f)) + 'no) + (check-equal? (say-no (apply-contract int->bool (lambda () "foo"))) + 'no) + (check-equal? (say-no (apply-contract int->bool (lambda (x y) "foo"))) + 'no) + (let ((proc (say-no (apply-contract int->bool (lambda (x) (odd? x)))))) + (check-pred procedure? proc) + (check-equal? (proc 15) #t) + (check-equal? (proc 16) #f) + (check-equal? (say-no (proc 12 15)) 'no) + (check-equal? (say-no (proc "foo")) 'no)) + (let ((proc (say-no (apply-contract int->bool (lambda (x) (+ x 1)))))) + (check-equal? (say-no (proc 12)) 'no))) + +)) + + +(define all-contract-tests + (test-suite + "all-contract-tests" + contract-tests + contract-syntax-tests)) diff --git a/collects/tests/deinprogramm/image.ss b/collects/tests/deinprogramm/image.ss new file mode 100644 index 0000000000..41d41ab64e --- /dev/null +++ b/collects/tests/deinprogramm/image.ss @@ -0,0 +1,1037 @@ +#lang scheme/base + +(provide all-image-tests) + +(require (planet schematics/schemeunit:3) + deinprogramm/image + (only-in lang/private/imageeq image=?) + mred + mzlib/class + mrlib/cache-image-snip + lang/posn + htdp/error) + + +(define-values (image-snip1 image-snip2) + (let () + (define size 2) + + (define (do-draw c-bm m-bm) + (let ([bdc (make-object bitmap-dc% c-bm)]) + (send bdc clear) + (send bdc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) + (send bdc set-brush (send the-brush-list find-or-create-brush "red" 'solid)) + (send bdc draw-rectangle 0 0 size size) + (send bdc set-bitmap m-bm) + (send bdc clear) + (send bdc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) + (send bdc set-brush (send the-brush-list find-or-create-brush "black" 'solid)) + (send bdc draw-rectangle 0 0 (/ size 2) size) + (send bdc set-bitmap #f))) + + (define image-snip1 + (let* ([c-bm (make-object bitmap% size size)] + [m-bm (make-object bitmap% size size #t)]) + (do-draw c-bm m-bm) + (make-object image-snip% c-bm m-bm))) + + (define image-snip2 + (let* ([c-bm (make-object bitmap% size size)] + [m-bm (make-object bitmap% size size)]) + (do-draw c-bm m-bm) + (send c-bm set-loaded-mask m-bm) + (make-object image-snip% c-bm))) + + (values image-snip1 image-snip2))) + +(define image-snip3 (make-object image-snip%)) + +;; check-on-bitmap : symbol snip -> void +;; checks on various aspects of the bitmap snips to make +;; sure that they draw properly +(define (check-on-bitmap snp) + (let-values ([(width height) (send snp get-size)]) + (let ([bdc (make-object bitmap-dc%)] + [max-difference + (lambda (s1 s2) + (cond + [(and (zero? (bytes-length s1)) + (zero? (bytes-length s2))) + 0] + [else + (apply max + (map (lambda (x y) (abs (- x y))) + (bytes->list s1) + (bytes->list s1)))]))]) + + ;; test that no drawing is outside the snip's drawing claimed drawing area + (let* ([extra-space 100] + [bm-width (+ width extra-space)] + [bm-height (+ height extra-space)] + [bm-clip (make-object bitmap% bm-width bm-height)] + [bm-noclip (make-object bitmap% bm-width bm-height)] + [s-clip (make-bytes (* bm-width bm-height 4))] + [s-noclip (make-bytes (* bm-width bm-height 4))] + [s-trunc (make-bytes (* bm-width bm-height 4))]) + (send bdc set-bitmap bm-clip) + (send bdc clear) + (send bdc set-clipping-rect (/ extra-space 2) (/ extra-space 2) width height) + (send snp draw bdc (/ extra-space 2) (/ extra-space 2) 0 0 (+ width extra-space) (+ height extra-space) 0 0 #f) + (send bdc set-clipping-region #f) + (send bdc get-argb-pixels 0 0 (+ width extra-space) (+ height extra-space) s-clip) + + (send bdc set-bitmap bm-noclip) + (send bdc clear) + (send snp draw bdc (/ extra-space 2) (/ extra-space 2) 0 0 (+ width extra-space) (+ height extra-space) 0 0 #f) + (send bdc get-argb-pixels 0 0 (+ width extra-space) (+ height extra-space) s-noclip) + (send bdc set-bitmap #f) + + (check-equal? s-clip s-noclip) + + (send bdc set-bitmap bm-noclip) + (send bdc set-pen "black" 1 'transparent) + (send bdc set-brush "white" 'solid) + (send bdc draw-rectangle 0 0 (/ extra-space 2) bm-height) + (send bdc draw-rectangle (- bm-width (/ extra-space 2)) 0 (/ extra-space 2) bm-height) + (send bdc draw-rectangle 0 0 bm-width (/ extra-space 2)) + (send bdc draw-rectangle 0 (- bm-height (/ extra-space 2)) bm-width (/ extra-space 2)) + (send bdc get-argb-pixels 0 0 (+ width extra-space) (+ height extra-space) s-trunc) + + (check-equal? s-noclip s-trunc)) + + (let ([bm-normal (make-object bitmap% (max 1 width) (max 1 height))] + [bm-bitmap (make-object bitmap% (max 1 width) (max 1 height))] + [s-normal (make-bytes (* width height 4))] + [s-bitmap (make-bytes (* width height 4))]) + + (send bdc set-bitmap bm-normal) + (send bdc clear) + (send snp draw bdc 0 0 0 0 width height 0 0 #f) + (send bdc get-argb-pixels 0 0 width height s-normal) + (send bdc set-bitmap bm-bitmap) + (send bdc clear) + + ;; force the snip to switch over to bitmap mode + (send snp get-argb) + + (send snp draw bdc 0 0 0 0 width height 0 0 #f) + (send bdc get-argb-pixels 0 0 width height s-bitmap) + (send bdc set-bitmap #f) + (check-true (<= (max-difference s-normal s-bitmap) 2)))))) + +(define red (make-color 255 0 0)) +(define blue (make-color 0 0 255)) +(define black (make-color 0 0 0)) +(define white (make-color 255 255 255)) + +(define awhite (make-alpha-color 0 255 255 255)) +(define ablack (make-alpha-color 0 0 0 0)) +(define ared (make-alpha-color 0 255 0 0)) +(define aclr (make-alpha-color 255 0 0 0)) + +(define-simple-check (check-image=? i1 i2) + (image=? i1 i2)) + +(define-simple-check (check-not-image=? i1 i2) + (not (image=? i1 i2))) + +(define-simple-check (check-terminates val1) + #t) + +(define (add-line i x1 y1 x2 y2 color) + (overlay i + (line (image-width i) + (image-height i) + x1 y1 x2 y2 color) + "left" "top")) + +(define (not-image-inside? i1 i2) + (not (image-inside? i1 i2))) + +;; tests that the expression +;; a) raises a teachpack exception record, +;; b) has the right argument position, and +;; c) has the right name. +(define (tp-exn-pred name position) + (lambda (exn) + (and (tp-exn? exn) + (let* ([msg (exn-message exn)] + [beg (format "~a:" name)] + [len (string-length beg)]) + (and (regexp-match position msg) + ((string-length msg) . > . len) + (string=? (substring msg 0 len) beg)))))) + +(define-syntax err/rt-name-test + (syntax-rules () + [(_ (name . args) position) + (check-exn (tp-exn-pred 'name position) + (lambda () + (name . args)))])) + +(define all-image-tests + (test-suite + "Tests for images" + + (test-case + "image?" + (check-pred image? (rectangle 10 10 'solid 'blue)) + (check-pred image? (rectangle 10 10 "solid" 'blue)) + (check-pred image? (rectangle 10 10 'outline 'blue)) + (check-pred image? (rectangle 10 10 "outline" 'blue)) + (check-false (image? 5))) + + (test-case + "color-list" + (check-equal? (list red) + (image->color-list (rectangle 1 1 'solid 'red))) + (check-equal? (list blue blue blue blue) + (image->color-list (rectangle 2 2 'solid 'blue)))) + + (test-case + "colors-set-up-properly" + (check-equal? (list (list red) (list blue) (list black) (list white)) + (list (image->color-list (rectangle 1 1 'solid 'red)) + (image->color-list (rectangle 1 1 'solid 'blue)) + (image->color-list (rectangle 1 1 'solid 'black)) + (image->color-list (rectangle 1 1 'solid 'white))))) + + (test-case + "color-list2" + (check-equal? (list blue blue blue + blue blue blue + blue blue blue) + (image->color-list (rectangle 3 3 'solid 'blue))) + (check-equal? (list blue blue blue + blue blue blue + blue blue blue) + (image->color-list (rectangle 3 3 "solid" 'blue))) + (check-equal? (list blue blue blue + blue white blue + blue blue blue) + (image->color-list (rectangle 3 3 'outline 'blue)))) + + (test-case + "color-list3" + (check-equal? (list blue blue blue + blue white blue + blue blue blue) + (image->color-list (rectangle 3 3 "outline" 'blue)))) + + (test-case + "color-list4" + (check-image=? (color-list->image (list blue blue blue blue) 2 2) + (rectangle 2 2 'solid 'blue))) + (test-case + "color-list5" + (check-not-image=? (color-list->image (list blue blue blue blue) 2 2) + (rectangle 1 4 'solid 'blue))) + + (test-case + "color-list6" + (check-image=? (color-list->image (list blue blue blue blue) 1 4) + (rectangle 1 4 'solid 'blue))) + (test-case + "color-list7" + (check-image=? (color-list->image (list 'blue 'blue 'blue 'blue) 2 2) + (rectangle 2 2 'solid 'blue))) + + (test-case + "color-list8" + (check-equal? 10 + (image-width (color-list->image '() 10 0)))) + + (test-case + "color-list9" + (check-equal? 0 + (image-height (color-list->image '() 10 0)))) + + (test-case + "color-list10" + (check-equal? 0 + (image-width (color-list->image '() 0 10)))) + + (test-case + "color-list11" + (check-equal? 10 + (image-height (color-list->image '() 0 10)))) + + (test-case + "alpha-color-list1" + (check-equal? (make-alpha-color 0 255 0 0) + (car (image->alpha-color-list (rectangle 1 1 'solid 'red))))) + + (test-case + "alpha-color-list2" + (check-equal? (make-alpha-color 0 255 0 0) + (car (image->alpha-color-list (rectangle 1 1 "solid" 'red))))) + + (test-case + "alpha-color-list3" + (for-each + (lambda (x) + (check-equal? x (make-alpha-color 0 255 0 0))) + (image->alpha-color-list (rectangle 1 1 "solid" 'red)))) + + (test-case + "alpha-color-list4" + (for-each + (lambda (x) + (check-equal? x (make-alpha-color 0 255 0 0))) + (image->alpha-color-list (rectangle 1 1 'solid 'red)))) + + (test-case + "alpha-color-list5" + (check-equal? (make-alpha-color 0 0 255 0) + (car (image->alpha-color-list (rectangle 1 1 'solid 'green))))) + + (test-case + "alpha-color-list6" + (check-equal? (make-alpha-color 0 0 0 255) + (car (image->alpha-color-list (rectangle 1 1 'solid 'blue))))) + + (test-case + "alpha-color-list7" + (check-equal? (image-width + (alpha-color-list->image + (list ared aclr ared + aclr aclr aclr) + 3 + 2)) + 3)) + (test-case + "alpha-color-list8" + (check-equal? (image-height + (alpha-color-list->image + (list ared aclr ared + aclr aclr aclr) + 3 + 2)) + 2)) + + (test-case + "alpha-color-list9" + (check-equal? (image->color-list + (alpha-color-list->image + (list ared aclr ared + aclr aclr aclr) + 3 2)) + (list red white red + white white white))) + (test-case + "alpha-color-list10" + (check-equal? (image->color-list + (overlay + (rectangle 3 3 'solid 'blue) + (alpha-color-list->image + (list ared aclr ared + aclr aclr aclr + ared aclr ared) + 3 3) + "left" "top")) + (list red blue red + blue blue blue + red blue red))) + + (test-case + "alpha-color-list11" + (check-equal? 10 (image-width (alpha-color-list->image '() 10 0)))) + + (test-case + "alpha-color-list12" + (check-equal? 0 (image-height (alpha-color-list->image '() 10 0)))) + + (test-case + "alpha-color-list13" + (check-equal? 0 (image-width (alpha-color-list->image '() 0 10)))) + + (test-case + "alpha-color-list14" + (check-equal? 10 (image-height (alpha-color-list->image '() 0 10)))) + + (test-case + "image=?1" + (check-image=? (alpha-color-list->image (list (make-alpha-color 200 100 150 175)) 1 1) + (alpha-color-list->image (list (make-alpha-color 200 100 150 175)) 1 1))) + + (test-case + "image=?2" + (check-image=? (alpha-color-list->image (list (make-alpha-color 255 100 100 100)) 1 1) + (alpha-color-list->image (list (make-alpha-color 255 200 200 200)) 1 1))) + + (test-case + "image=?3" + (check-not-image=? (alpha-color-list->image (list (make-alpha-color 200 100 100 100)) 1 1) + (alpha-color-list->image (list (make-alpha-color 200 200 200 200)) 1 1))) + + (test-case + "image=?4" + (check-not-image=? (alpha-color-list->image (list (make-alpha-color 200 100 150 175) + (make-alpha-color 200 100 150 175)) + 1 + 2) + (alpha-color-list->image (list (make-alpha-color 200 100 150 175) + (make-alpha-color 200 100 150 175)) + 2 + 1))) + + (test-case + "image=?5" + (write (image=? (rectangle 4 4 'outline 'black) + (overlay + (rectangle 4 4 'outline 'black) + (circle 1 'solid 'red) + 1 1))) + + (check-not-image=? (rectangle 4 4 'outline 'black) + (overlay + (rectangle 4 4 'outline 'black) + (circle 1 'solid 'red) + 0 0))) + + (test-case + "overlay" + (check-image=? (color-list->image (list blue red blue red) 2 2) + (overlay (rectangle 2 2 'solid 'red) + (rectangle 1 2 'solid 'blue) + "left" "top"))) + + (test-case + "overlay/multiple" + (check-image=? (overlay (rectangle 6 6 'solid 'red) + (overlay (rectangle 4 4 'solid 'white) + (rectangle 2 2 'solid 'blue) + "center" "center") + "center" "center") + (overlay (overlay (rectangle 6 6 'solid 'red) + (rectangle 4 4 'solid 'white) + "center" "center") + (rectangle 2 2 'solid 'blue) + "center" "center"))) + + (test-case + "overlay/empty-spaces-are-unmasked" + (check-image=? (color-list->image (list red red red blue) 2 2) + (overlay + (rectangle 2 2 'solid 'blue) + (overlay (rectangle 1 2 'solid 'red) + (rectangle 2 1 'solid 'red) + "left" "top") + "left" "top"))) + + (test-case + "overlay/xy1" + (check-image=? (color-list->image (list red blue red blue) 2 2) + (overlay (rectangle 2 2 'solid 'red) + (rectangle 1 2 'solid 'blue) + 1 0))) + + (test-case + "overlay/xy2" + (check-image=? (color-list->image (list red red red blue) 2 2) + (overlay (rectangle 2 2 'solid 'red) + (rectangle 1 1 'solid 'blue) + 1 1))) + + (test-case + "overlay/xy3" + (check-image=? (color-list->image (list red red blue blue) 2 2) + (overlay (rectangle 2 1 'solid 'red) + (rectangle 2 1 'solid 'blue) + 0 1))) + + (test-case + "overlay/xy/white" + (check-image=? (alpha-color-list->image (list ablack ablack ablack + ablack awhite ablack + ablack ablack ablack) + 3 3) + (overlay (rectangle 3 3 'solid 'black) + (rectangle 1 1 'solid 'white) + 1 1))) + + (test-case + "color-list->image/white-in-mask" + (check-image=? (color-list->image (list black red black + red red red + black red black) + 3 3) + (overlay (rectangle 3 3 'solid 'red) + (color-list->image (list black white black + white white white + black white black) + 3 3) + "left" "top"))) + + + (test-case + "overlay" + (check-image=? (color-list->image (list red blue red red blue red) 3 2) + (overlay (rectangle 3 2 'solid 'red) + (rectangle 1 2 'solid 'blue) + 1 0))) + + (test-case + "image=?-zero1" + (check-image=? (rectangle 0 10 'solid 'red) + (rectangle 0 10 'solid 'red))) + (test-case + "image=?-zero2" + (check-image=? (rectangle 0 10 'solid 'red) + (rectangle 0 10 'solid 'blue))) + (test-case + "image=?-zero3" + (check-not-image=? (rectangle 0 5 'solid 'red) + (rectangle 0 4'solid 'blue))) + + (test-case + "image-inside?1" + (check image-inside? + (overlay (rectangle 3 2 'solid 'red) + (rectangle 1 2 'solid 'blue) + 1 0) + (rectangle 1 2 'solid 'blue))) + + (test-case + "image-inside?2" + (check not-image-inside? + (overlay (rectangle 3 2 'solid 'red) + (rectangle 1 2 'solid 'blue) + 1 0) + (rectangle 1 2 'solid 'black))) + + (test-case + "image-inside?3" + (check image-inside? + (overlay (rectangle 3 2 'solid 'red) + (rectangle 1 2 'solid 'blue) + 1 0) + (rectangle 1 2 'solid 'red))) + + (test-case + "image-inside?4" + (check not-image-inside? + (overlay (rectangle 3 2 'solid 'red) + (rectangle 1 2 'solid 'blue) + 1 0) + (rectangle 2 1 'solid 'red))) + + (test-case + "image-inside?5" + (check image-inside? + (alpha-color-list->image (list (make-alpha-color 0 255 0 0)) 1 1) + (alpha-color-list->image (list (make-alpha-color 255 0 0 0)) 1 1))) + + (test-case + "image-inside?6" + (check not-image-inside? + (overlay (rectangle 3 2 'solid 'red) + (rectangle 1 2 'solid 'blue) + 1 0) + (color-list->image (list blue white white) + 3 1))) + + (test-case + "image-inside?7" + (check image-inside? + (overlay (rectangle 16 16 'solid 'red) + (ellipse 6 6 'outline 'blue) + 2 5) + (ellipse 6 6 'outline 'blue))) + + (test-case + "image-inside?8" + (check image-inside? + (overlay (rectangle (image-width (text "x" 12 'red)) + (image-height (text "x" 12 'red)) + 'solid + 'white) + (text "x" 12 'red) + "center" "center") + (text "x" 12 'red))) + + (test-case + "image-inside?9" + (check image-inside? + (text "y x y" 12 'red) + (text "x" 12 'red))) + + (test-case + "find-image1" + (check-equal? (make-posn 2 5) + (find-image (overlay (rectangle 16 16 'solid 'red) + (ellipse 6 6 'outline 'blue) + 2 5) + (ellipse 6 6 'outline 'blue)))) + + (test-case + "find-image2" + (check-equal? (make-posn 0 0) + (find-image (rectangle 16 16 'solid 'blue) + (ellipse 6 6 'outline 'blue)))) + + (test-case + "find-image3" + (check-equal? (make-posn 1 1) + (find-image (overlay (rectangle 10 10 'solid 'blue) + (ellipse 5 5 'solid 'red) + 1 1) + (ellipse 5 5 'solid 'red)))) + + (test-case + "image-width" + (check-equal? 5 (image-width (rectangle 5 7 'solid 'red)))) + + (test-case + "image-height" + (check-equal? 7 (image-height (rectangle 5 7 'solid 'red)))) + + (test-case + "color-red" + (check-equal? 1 (color-red (make-color 1 2 3)))) + + (test-case + "color-green" + (check-equal? 2 (color-green (make-color 1 2 3)))) + + (test-case + "color-blue" + (check-equal? 3 (color-blue (make-color 1 2 3)))) + + (test-case + "color?1" + (check-true (color? (make-color 1 2 3)))) + + (test-case + "color?2" + (check-false (color? 10))) + + (test-case + "image-color?1" + (check-pred image-color? (make-color 1 2 3))) + + (test-case + "image-color?2" + (check-pred image-color? "blue")) + + (test-case + "image-color?3" + (check-pred image-color? 'blue)) + + (test-case + "image-color?4" + (check-false (image-color? 10))) + + (test-case + "image-color?5" + (check-false (image-color? "not-a-color"))) + + (test-case + "image-color?6" + (check-false (image-color? 'not-a-color))) + + (test-case + "line" + (check image=? + (line 5 1 0 0 4 0 'red) + (color-list->image (list red red red red red) 5 1)) + (check image=? + (line 1 5 0 0 0 4 'red) + (color-list->image (list red red red red red) 1 5)) + + (check image=? + (line 1 5 0 4 0 0 'red) + (color-list->image (list red red red red red) 1 5)) + + (check image=? + (line 5 1 4 0 0 0 'red) + (color-list->image (list red red red red red) 5 1))) + + +; note: next two tests may be platform-specific... I'm not sure. + ;; I developed them under macos x. -robby + (test-case + "triangle1" + (check image=? + (triangle 3 'outline 'red) + (color-list->image + (list white red white + white red white + red white red + red red red) + 3 + 4))) + + (test-case + "triangle2" + (check image=? + (triangle 3 'solid 'red) + (color-list->image + (list white red white + white red white + red red red + red red red) + 3 + 4))) + + (test-case + "clipping-twice-clips-both-times" + (check image=? + (overlay + (rectangle 11 11 'solid 'green) + (clip (rectangle 11 11 'solid 'red) + 5 5 1 1) + "center" "center") + (overlay + (rectangle 11 11 'solid 'green) + (clip (clip (rectangle 11 11 'solid 'red) + 3 3 2 2) + 2 2 1 1) + "center" "center"))) + + (test-case + "solid-rect" + (check-on-bitmap (rectangle 2 2 'solid 'red))) + + (test-case + "outline-rect" + (check-on-bitmap (rectangle 2 2 'outline 'red))) + (test-case + "solid-ellipse" + (check-on-bitmap (ellipse 2 4 'solid 'red))) + (test-case + "outline-ellipse" + (check-on-bitmap (ellipse 2 4 'outline 'red))) + (test-case + "solid-circle" + (check-on-bitmap (circle 4 'solid 'red))) + (test-case + "outline-circle" + (check-on-bitmap (circle 4 'outline 'red))) + + (test-case + "0solid-rect1" + (check-on-bitmap (rectangle 0 2 'solid 'red))) + (test-case + "0solid-rect2" + (check-on-bitmap (rectangle 2 0 'solid 'red))) + (test-case + "0outline-rect1" + (check-on-bitmap (rectangle 2 0 'outline 'red))) + (test-case + "0outline-rect2" + (check-on-bitmap (rectangle 0 0 'outline 'red))) + (test-case + "0solid-ellipse1" + (check-on-bitmap (ellipse 0 3 'solid 'red))) + (test-case + "0solid-ellipse2" + (check-on-bitmap (ellipse 3 0 'solid 'red))) + (test-case + "0outline-ellipse1" + (check-on-bitmap (ellipse 0 4 'outline 'red))) + (test-case + "0outline-ellipse2" + (check-on-bitmap (ellipse 2 0 'outline 'red))) + (test-case + "0solid-circle" + (check-on-bitmap (circle 0 'solid 'red))) + (test-case + "0outline-circle" + (check-on-bitmap (circle 0 'outline 'red))) + + (test-case + "solid-triangle" + (check-on-bitmap (triangle 10 'solid 'red))) + (test-case + "outline-triangle" + (check-on-bitmap (triangle 10 'outline 'red))) + (test-case + "line" + (check-on-bitmap (line 10 7 0 0 9 6 'red))) + + + + ;; (check-on-bitmap 'text (text "XX" 12 'red)) ;; this test fails for reasons I can't control ... -robby + (test-case + "overlay1" + (check-on-bitmap (overlay (rectangle 1 4 'solid 'blue) + (rectangle 4 1 'solid 'green) + "left" "top"))) + (test-case + "overlay2" + (check-on-bitmap (overlay (rectangle 4 4 'solid 'blue) + (rectangle 4 4 'solid 'green) + 2 2))) + (test-case + "overlay3" + (check-on-bitmap (overlay image-snip1 + (rectangle (image-width image-snip1) + (image-height image-snip1) + 'outline + 'red) + "center" "center"))) + (test-case + "alpha-color-list" + (check-on-bitmap + (overlay + (rectangle 3 3 'solid 'blue) + (alpha-color-list->image + (list ared aclr ared + aclr aclr aclr + ared aclr ared) + 3 + 3) + "center" "center"))) + (test-case + "add-line" + (check-on-bitmap + (overlay + (rectangle 100 100 'solid 'black) + (line 100 100 -10 -10 110 110 'red) + 0 0))) + + (test-case + "add-line1" + (check-on-bitmap + (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") + -20 -20 + 0 0 + 'red))) + (test-case + "add-line2" + (check-on-bitmap + (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") + -20 20 + 0 0 + 'red))) + (test-case + "add-line3" + (check-on-bitmap + (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") + 20 -20 + 0 0 + 'red))) + + (test-case + "add-line4" + (check-on-bitmap + (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") + 20 20 + 0 0 + 'red))) + + (test-case + "add-line5" + (check-on-bitmap + (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") + 0 0 + -20 -20 + 'red))) + + (test-case + "add-line6" + (check-on-bitmap + (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") + 0 0 + -20 20 + 'red))) + + (test-case + "add-line7" + (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") + 0 0 + 20 -20 + 'red)) + + (test-case + "add-line8" + (check-on-bitmap + (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") + 0 0 + 20 20 + 'red))) + + (test-case + "shrink" + (check-on-bitmap + (clip (rectangle 11 11 'solid 'red) + 5 5 1 1))) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; test images with zero width or zero height + ;; for various things + ;; + + (test-case + "zero-width/height" + (check-equal? 10 (image-width (rectangle 10 0 'solid 'red))) + (check-equal? 0 (image-height (rectangle 10 0 'solid 'red))) + (check-equal? 0 (image-width (rectangle 0 10 'solid 'red))) + (check-equal? 10 (image-height (rectangle 0 10 'solid 'red))) + + (check-equal? 0 (image-width (text "" 12 'black))) + (check > (image-height (text "" 12 'black)) 0) + + (check-equal? '() (image->color-list (rectangle 0 10 'solid 'red))) + (check-equal? '() (image->color-list (rectangle 10 0 'solid 'red))) + (check-equal? '() (image->color-list (rectangle 0 0 'solid 'red))) + + (check-equal? '() (image->alpha-color-list (rectangle 0 10 'solid 'red))) + (check-equal? '() (image->alpha-color-list (rectangle 10 0 'solid 'red))) + (check-equal? '() (image->alpha-color-list (rectangle 0 0 'solid 'red)))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; test that the image construction functions + ;; accept non-integer values (and floor them) + ;; + + (test-case + "accept-non-integer" + (check-equal? (image->color-list (rectangle 2 2 'solid 'blue)) + (image->color-list (rectangle #e2.5 2.5 'solid 'blue))) + (check-equal? (image->color-list (ellipse 2 2 'solid 'blue)) + (image->color-list (ellipse #e2.5 2.5 'solid 'blue))) + (check-equal? (image->color-list (circle 2 'solid 'blue)) + (image->color-list (circle #e2.5 'solid 'blue))) + (check-equal? (image->color-list (triangle 12 'solid 'blue)) + (image->color-list (triangle 12.5 'solid 'blue))) + (check-equal? (image->color-list (line 10 12 0 0 9 11 'blue)) + (image->color-list (line 10 12 0 0 9.5 #e11.5 'blue))) + (check-equal? (image->color-list (clip (rectangle 10 10 'solid 'blue) 3 3 4 4)) + (image->color-list + (clip (rectangle 10 10 'solid 'blue) + 3.1 + 3.2 + #e4.3 + 4.4))) + (check-equal? (image->color-list (add-line (rectangle 10 10 'solid 'blue) + 0 0 2 2 'red)) + (image->color-list (add-line (rectangle 10 10 'solid 'blue) + 0.1 #e.2 2.1 2.2 'red)))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; The tests beginning with "bs-" ensure + ;; that the operations all can accept bitmap + ;; snips as arguments + ;; + + (test-case + "accept-bitmap" + (check-pred image? image-snip1) + (check-pred image? image-snip2) + (check image=? image-snip1 (send image-snip1 copy)) + (check-not-image=? + ;; They have different masks: + image-snip1 image-snip2) + (check-equal? 2 (image-width image-snip1)) + (check-equal? 2 (image-width image-snip2)) + (check-equal? 2 (image-height image-snip1)) + (check-equal? 2 (image-height image-snip2)) + (check image=? image-snip1 (overlay image-snip1 image-snip2 "center" "center")) + (check image=? image-snip1 (overlay image-snip1 image-snip2 "left" "top")) + (check image=? + (add-line image-snip1 0 0 10 10 'green) + (add-line image-snip2 0 0 10 10 'green)) + (check image-inside? image-snip1 image-snip2) + (check image-inside? image-snip2 image-snip1) + (check-equal? (make-posn 0 0) + (find-image image-snip1 image-snip2)) + (check-equal? (make-posn 0 0) + (find-image image-snip2 image-snip1)) + (check-equal? (image->color-list image-snip1) + (image->color-list image-snip2)) + (check-equal? (image->alpha-color-list image-snip1) + (image->alpha-color-list image-snip2))) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; test image-snip that doesnt' have a bitmap + ;; + + (test-case + "image-snip-no-bitmap" + (check-equal? 20 + (image-width image-snip3)) + (overlay image-snip3 image-snip3 10 10)) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; test color arguments + ;; + (test-case + "color-arguments" + (check-terminates (rectangle 10 10 'solid 'blue)) + (check-terminates (rectangle 10 10 'solid "blue")) + (check-terminates (rectangle 10 10 'solid (make-color 0 0 255))) + (check-terminates (ellipse 10 10 'solid 'blue)) + (check-terminates (ellipse 10 10 'solid "blue")) + (check-terminates (ellipse 10 10 'solid (make-color 0 0 255))) + (check-terminates (circle 10 'solid 'blue)) + (check-terminates (circle 10 'solid "blue")) + (check-terminates (circle 10 'solid (make-color 0 0 255))) + (check-terminates (triangle 10 'solid 'blue)) + (check-terminates (triangle 10 'solid "blue")) + (check-terminates (triangle 10 'solid (make-color 0 0 255))) + (check-terminates (line 10 10 0 0 9 9 'blue)) + (check-terminates (line 10 10 0 0 9 9 "blue")) + (check-terminates (line 10 10 0 0 9 9 (make-color 0 0 255))) + (check-terminates (add-line (rectangle 1 1 'solid 'blue) 0 0 1 1 'blue)) + (check-terminates (add-line (rectangle 1 1 'solid 'blue) 0 0 1 1 "blue")) + (check-terminates (add-line (rectangle 1 1 'solid 'blue) 0 0 1 1 (make-color 0 0 255))) + (check-terminates (text "abc" 12 'blue)) + (check-terminates (text "abc" 12 "blue")) + (check-terminates (text "abc" 12 (make-color 0 0 255)))) + + (test-case + "error-message" + (err/rt-name-test (image-width 1) "first") + (err/rt-name-test (image-height 1) "first") + (err/rt-name-test (overlay 1 2 "center" "center") "first") + (err/rt-name-test (overlay image-snip1 2 "center" "center") "second") + (err/rt-name-test (overlay 1 2 "center" "center") "first") + (err/rt-name-test (overlay image-snip1 image-snip2 "foo" "center") "third") + (err/rt-name-test (overlay image-snip1 image-snip2 "center" "foo") "fourth") + (err/rt-name-test (rectangle #f #f #f #f) "first") + (err/rt-name-test (rectangle 10 #f #f #f) "second") + (err/rt-name-test (rectangle 10 10 #f #f) "third") + (err/rt-name-test (rectangle 10 10 'solid #f) "fourth") + (err/rt-name-test (circle #f #f #f) "first") + (err/rt-name-test (circle 10 #f #f) "second") + (err/rt-name-test (circle 10 'solid #f) "third") + (err/rt-name-test (ellipse #f #f #f #f) "first") + (err/rt-name-test (ellipse 10 #f #f #f) "second") + (err/rt-name-test (ellipse 10 10 #f #f) "third") + (err/rt-name-test (ellipse 10 10 'solid #f) "fourth") + (err/rt-name-test (triangle #f #f #f) "first") + (err/rt-name-test (triangle 10 #f #f) "second") + (err/rt-name-test (triangle 10 'solid #f) "third") + (err/rt-name-test (line #f #f 0 0 0 0 #f) "first") + (err/rt-name-test (line 10 #f 0 0 0 0 #f) "second") + (err/rt-name-test (line 10 10 #f 0 0 0 #f) "third") + (err/rt-name-test (line 10 10 0 #f 0 0 #f) "fourth") + (err/rt-name-test (line 10 10 0 0 #f 0 #f) "fifth") + (err/rt-name-test (line 10 10 0 0 0 #f #f) "sixth") + (err/rt-name-test (line 10 10 0 0 0 0 #f) "seventh") + (err/rt-name-test (text #f #f #f) "first") + (err/rt-name-test (text "abc" #f #f) "second") + (err/rt-name-test (text "abc" 10 #f) "third") + (err/rt-name-test (image-inside? #f #f) "first") + (err/rt-name-test (image-inside? image-snip1 #f) "second") + (err/rt-name-test (find-image #f #f) "first") + (err/rt-name-test (find-image image-snip1 #f) "second") + (err/rt-name-test (image->color-list 1) "first") + (err/rt-name-test (color-list->image #f #f #f) "first") + (err/rt-name-test (color-list->image (list (make-color 0 0 0)) #f #f) "second") + (err/rt-name-test (color-list->image (list (make-color 0 0 0)) 1 #f) "third") + (err/rt-name-test (image->alpha-color-list #f) "first") + (err/rt-name-test (alpha-color-list->image #f #f #f) "first") + (err/rt-name-test (alpha-color-list->image (list (make-alpha-color 0 0 0 0)) #f #f) "second") + (err/rt-name-test (alpha-color-list->image (list (make-alpha-color 0 0 0 0)) 1 #f) "third")) +)) diff --git a/collects/tests/deinprogramm/run-contract-tests.ss b/collects/tests/deinprogramm/run-contract-tests.ss new file mode 100644 index 0000000000..c375180247 --- /dev/null +++ b/collects/tests/deinprogramm/run-contract-tests.ss @@ -0,0 +1,6 @@ +#lang scheme/base + +(require (planet schematics/schemeunit:3/text-ui)) +(require tests/deinprogramm/contract) + +(run-tests all-contract-tests) \ No newline at end of file diff --git a/collects/tests/deinprogramm/run-image-test.ss b/collects/tests/deinprogramm/run-image-test.ss new file mode 100644 index 0000000000..06215561da --- /dev/null +++ b/collects/tests/deinprogramm/run-image-test.ss @@ -0,0 +1,6 @@ +#lang scheme/base + +(require (planet schematics/schemeunit:3/text-ui)) +(require tests/deinprogramm/image) + +(run-tests all-image-tests) \ No newline at end of file diff --git a/collects/tests/eli-tester.ss b/collects/tests/eli-tester.ss index 48ccc17619..0fb6027370 100644 --- a/collects/tests/eli-tester.ss +++ b/collects/tests/eli-tester.ss @@ -7,19 +7,28 @@ (syntax-case stx () [(_ expr) ;; catch syntax errors while expanding, turn them into runtime errors - (with-handlers ([exn? (lambda (e) #`(list 'error #,(exn-message e)))]) + (with-handlers ([exn? (lambda (e) #`(list 'error #,(exn-message e) #,e))]) (define-values (_ opaque) (syntax-local-expand-expression - #'(with-handlers ([exn? (lambda (e) (list 'error (exn-message e)))]) + #'(with-handlers + ([(lambda (_) #t) + (lambda (e) (list 'error (and (exn? e) (exn-message e)) e))]) (cons 'values (call-with-values (lambda () expr) list))))) opaque)])) (define show - (match-lambda [(list 'error msg) (format "error: ~a" msg)] - [(list 'values x) (format "~e" x)] - [(list 'values xs ...) (format "~e" (cons 'values xs))])) + (match-lambda + [(list 'values x) (format "~e" x)] + [(list 'values xs ...) (format "~e" (cons 'values xs))] + [(list 'error err val) + (cond [(procedure? err) (format "error satisfying ~s" err)] + [(regexp? err) (format "error matching ~s" err)] + [err (format "error: ~a" err)] + [else (format "a raised non-exception ~s" val)])] + [x (format "INTERNAL ERROR, unexpected value: ~s" x)])) -(define test-context (make-parameter #f)) +(define test-context (make-parameter #f)) +(define failure-message (make-parameter #f)) (define-syntax (test-thunk stx) (define (blame e fmt . args) @@ -32,22 +41,44 @@ [(syntax-position e) => (lambda (p) (format "#~a" p))] [else "?"]))))) (with-syntax ([e e] [fmt fmt] [(arg ...) args] [loc loc]) - #'(error 'loc "test failure in ~e\n ~a" 'e (format fmt arg ...)))) + #'(let ([msg (failure-message)]) + (if msg + (error 'loc "test failure\n ~a" (msg)) + (error 'loc "test failure in ~e\n ~a" 'e (format fmt arg ...)))))) (define (t1 x) #`(let ([x (safe #,x)]) (unless (and (eq? 'values (car x)) (= 2 (length x)) (cadr x)) #,(blame x "expected non-#f single value; got: ~a" #'(show x))))) - (define (t2 x y) - #`(let ([x (safe #,x)] [y (safe #,y)]) - (cond [(and (eq? 'values (car x)) (eq? 'error (car y))) - #,(blame x "expected an error; got ~a" #'(show x))] - [(and (eq? 'error (car x)) (eq? 'error (car y))) - (unless (regexp-match? (regexp-quote (cadr y)) (cadr x)) - #,(blame x "bad error message, expected ~s; got ~s" - #'(cadr y) #'(cadr x)))] - [(not (equal? x y)) - #,(blame x "expected ~a; got: ~a" #'(show y) #'(show x))]))) - (define (te x y) (t2 x #`(error #,y))) + (define (t2 x y [eval2? #t]) + #`(let* ([x (safe #,x)] [xtag (car x)] + [y #,(if eval2? #`(safe #,y) y)] [ytag (car y)]) + (cond + [(eq? ytag 'values) + (unless (equal? x y) + #,(blame x "expected ~a; got: ~a" #'(show y) #'(show x)))] + [(eq? xtag 'values) + #,(blame x "expected an error; got ~a" #'(show x))] + ;; both are errors (or other raised values) + [(not (cadr x)) ; expecting a non-exception raise + (unless (or (equal? x y) + (and (procedure? (cadr y)) ((cadr y) (caddr x)))) + #,(blame x "expected ~a; got ~a" #'(show y) #'(show x)))] + [else + (let ([xerr (cadr x)] [xval (caddr x)] [yerr (cadr y)]) + (cond [(string? yerr) + (unless (regexp-match? (regexp-quote yerr) xerr) + #,(blame x "bad error message, expected ~s; got ~s" + #'yerr #'xerr))] + [(regexp? yerr) + (unless (regexp-match? yerr xerr) + #,(blame x "bad error message, expected ~a ~s; got ~s" + "a match for" #'yerr #'xerr))] + [(and (procedure? yerr) (procedure-arity-includes? yerr 1)) + (unless (yerr xval) + #,(blame x "bad error message, expected ~a ~s; got ~s" + "an exception satisfying" #'yerr #'xerr))] + [else (error 'test "bad error specification: ~e" yerr)]))]))) + (define (te x y) (t2 x #`(list 'error #,y #f) #f)) (define (try t . args) #`(let ([c (test-context)]) (with-handlers ([exn? (lambda (e) (set-mcdr! c (cons e (mcdr c))))]) @@ -55,23 +86,35 @@ #,(apply t args)))) (define (tb x) x) (let loop ([xs (map (lambda (x) - (if (memq (syntax-e x) '(do => <= =error> <= =error> list stx)))] [r '()]) - (let ([t (match xs - [(list* 'do x r) (cons (tb x) r)] - [(list* x '=> y r) (cons (try t2 x y) r)] - [(list* y '<= x r) (cons (try t2 x y) r)] - [(list* x '=error> y r) (cons (try te x y) r)] - [(list* y ' y r) (cons (try t2 x y) r)] + [(list* y '<= x r) (cons (try t2 x y) r)] + [(list* x '=error> y r) (cons (try te x y) r)] + [(list* y ' "if: bad syntax" + ;; error (and non-exception raises) predicates + (+ 1 "2") =error> exn:fail:contract? + (+ 1 "2") =error> (lambda (x) (not (exn:fail:filesystem? x))) + (+ 1 "2") =error> #rx"expects.*" + (error "1") =error> exn? + (raise 1) =error> number? + (raise "1") =error> string? + ;; test `test' errors (test* (/ 0)) =error> "expected non-#f single value" (test* 1 => 2) =error> "expected 2" (test* 1 =error> "") =error> "expected an error" (test* (/ 0) =error> "zzz") =error> "bad error message" + (test* (raise 1) =error> "foo") =error> "raised non-exception" + (test* #:failure-message "FOO" (/ 0) => 1) =error> "FOO" + (test* #:failure-message "FOO" (/ 0)) =error> "FOO" ) ;; SchemeUnit stuff diff --git a/collects/tests/mzscheme/gzip.ss b/collects/tests/file/gzip.ss similarity index 62% rename from collects/tests/mzscheme/gzip.ss rename to collects/tests/file/gzip.ss index e40ea2a22e..8904eeceb6 100644 --- a/collects/tests/mzscheme/gzip.ss +++ b/collects/tests/file/gzip.ss @@ -1,3 +1,47 @@ +#lang scheme/base +(require file/gzip file/gunzip scheme/file tests/eli-tester) + +(define ((io->str-op io) buf [check-ratio #f]) + (let* ([b? (bytes? buf)] + [i (if b? (open-input-bytes buf) (open-input-string buf))] + [o (if b? (open-output-bytes) (open-output-string))]) + (io i o) + (let ([res (if b? (get-output-bytes o) (get-output-string o))]) + (when check-ratio + (if b? + (check-ratio (bytes-length buf) (bytes-length res)) + (check-ratio (string-length buf) (string-length res)))) + res))) + +(define deflate* (io->str-op deflate)) +(define inflate* (io->str-op inflate)) + +(define (id* buf [ratio #f]) + (test (inflate* (deflate* buf (and ratio (lambda (i o) + (test (< (/ o i) ratio)))))) + => buf)) + +(define (test-big-file) + (define big-file + (build-path (collection-path "drscheme/private") "unit.ss")) + ;; should be around 6 times smaller + (id* (file->bytes big-file) 4)) + +(define (run-tests) + (define (rand-bytes) + (list->bytes (for/list ([j (in-range (random 1000))]) (random 256)))) + (test-big-file) + (for ([i (in-range 100)]) (id* (rand-bytes)))) + +(provide tests) +(define (tests) (test do (run-tests))) + + +#| + +;; ELI: These are the old tests; I think that the only thing that +;; should be added from this to the above is trying the file-related +;; functionality (check that the filename is kept etc). (require mzlib/deflate mzlib/inflate) @@ -91,3 +135,5 @@ (directory-list)) |# + +|# diff --git a/collects/tests/file/main.ss b/collects/tests/file/main.ss new file mode 100644 index 0000000000..37d31538d6 --- /dev/null +++ b/collects/tests/file/main.ss @@ -0,0 +1,9 @@ +#lang scheme/base + +(require tests/eli-tester + (prefix-in gzip: "gzip.ss")) + +(define (tests) + (test do (begin (gzip:tests)))) + +(tests) diff --git a/collects/tests/info.ss b/collects/tests/info.ss index 05abf1ffb9..5fd8b6aad9 100644 --- a/collects/tests/info.ss +++ b/collects/tests/info.ss @@ -6,6 +6,7 @@ (define compile-omit-paths '("aligned-pasteboard" + "deinprogramm" "honu" "match" "macro-debugger" diff --git a/collects/tests/macro-debugger/gentests.ss b/collects/tests/macro-debugger/gentests.ss index ca2254d488..ec0c9fd71e 100644 --- a/collects/tests/macro-debugger/gentests.ss +++ b/collects/tests/macro-debugger/gentests.ss @@ -57,7 +57,7 @@ [expect-ok? (cdr key+expect-ok?)]) (check-hide d hide-none-policy expect-ok?) (check-hide d hide-all-policy expect-ok?) - (check-hide d simple-policy expect-ok?))))] + (check-hide d T-policy expect-ok?))))] [else #f])) (define (check-hide d policy expect-ok?) @@ -86,14 +86,14 @@ (error 'checker-for-hidden-steps "no steps given for ~s" label)) (test-case label (let* ([d (trace/ns form (assq '#:kernel attrs))] - [rs (parameterize ((macro-policy simple-policy)) + [rs (parameterize ((macro-policy T-policy)) (reductions d))]) (check-steps (cdr (assq '#:steps attrs)) rs)))] [(assq '#:hidden-steps attrs) => (lambda (key+expected) (test-case label (let* ([d (trace/ns form (assq '#:kernel attrs))] - [rs (parameterize ((macro-policy simple-policy)) + [rs (parameterize ((macro-policy T-policy)) (reductions d))]) (check-steps (cdr (assq '#:hidden-steps attrs)) rs))))] [else #f])) diff --git a/collects/tests/macro-debugger/test-setup.ss b/collects/tests/macro-debugger/test-setup.ss index 7852037511..5fdb4646b0 100644 --- a/collects/tests/macro-debugger/test-setup.ss +++ b/collects/tests/macro-debugger/test-setup.ss @@ -8,12 +8,15 @@ trace/k hide-all-policy hide-none-policy - simple-policy + + T-policy + Tm-policy stx/hide-none stx/hide-all stx/hide-standard - stx/hide-simple) + stx/hide-T + stx/hide-Tm) (define (trace/t expr) (trace/ns expr #f)) @@ -133,22 +136,25 @@ (stx/hide-policy d hide-none-policy)) (define (stx/hide-all d) (stx/hide-policy d hide-all-policy)) -(define (stx/hide-simple d) - (stx/hide-policy d simple-policy)) (define (stx/hide-standard d) (stx/hide-policy d standard-policy)) -#| -(define (hide/standard d) (hide/policy d standard-policy)) -(define (hide/all d) (hide/policy d hide-all-policy)) -(define (hide/null d) (hide/policy d hide-none-policy)) -(define (hide/except d syms) - (hide/policy d (lambda (id) (memq (syntax-e id) syms)))) -(define (hide/simple d) (hide/policy d simple-policy)) -|# -;; Simple hiding policy -;; ALL MACROS & primitive tags are hidden -;; EXCEPT Tlist and Tlet (and #%module-begin) -(define (simple-policy id) +(define (stx/hide-T d) + (stx/hide-policy d T-policy)) +(define (stx/hide-Tm d) + (stx/hide-policy d Tm-policy)) + +;; T hiding policy +;; ALL macros & primitives are hidden +;; EXCEPT those starting with T (Tlist and Tlet) +(define (T-policy id) (or (memq (syntax-e id) '()) (regexp-match #rx"^T" (symbol->string (syntax-e id))))) + +;; Tm hiding policy +;; ALL MACROS & primitive tags are hidden +;; EXCEPT those starting with T (Tlist and Tlet) +;; EXCEPT module (=> #%module-begin gets tagged) +(define (Tm-policy id) + (or (memq (syntax-e id) '(module)) + (regexp-match #rx"^T" (symbol->string (syntax-e id))))) diff --git a/collects/tests/macro-debugger/tests/hiding.ss b/collects/tests/macro-debugger/tests/hiding.ss index 1131ec2ff3..8cf25d2a02 100644 --- a/collects/tests/macro-debugger/tests/hiding.ss +++ b/collects/tests/macro-debugger/tests/hiding.ss @@ -1,7 +1,6 @@ #lang scheme/base (require (planet "test.ss" ("schematics" "schemeunit.plt" 2 8)) - (planet "graphical-ui.ss" ("schematics" "schemeunit.plt" 2 8)) macro-debugger/model/debug "../test-setup.ss") (provide specialized-hiding-tests) @@ -27,16 +26,19 @@ [(tthi form) (test-trivial-hiding form form)])) -(define-syntax test-simple-hiding - (syntax-rules () - [(tsh form hidden-e2) - (test-hiding/policy form hidden-e2 simple-policy)])) -(define-syntax test-simple-hiding/id - (syntax-rules () - [(tshi form) (test-simple-hiding form form)])) +(define-syntax-rule (test-T-hiding form hidden-e2) + (test-hiding/policy form hidden-e2 T-policy)) +(define-syntax-rule (test-T-hiding/id form) + (test-T-hiding form form)) + +(define-syntax-rule (test-Tm-hiding form hidden-e2) + (test-hiding/policy form hidden-e2 Tm-policy)) +(define-syntax-rule (test-Tm-hiding/id form) + (test-Tm-hiding form form)) (define specialized-hiding-tests (test-suite "Specialized macro hiding tests" + (test-suite "Result tests for trivial hiding" (test-suite "Atomic expressions" (test-trivial-hiding/id *) @@ -74,7 +76,7 @@ (lambda (x y) x y)) (test-trivial-hiding (lambda (x) (define-values (y) (id x)) y) (lambda (x) (letrec-values ([(y) x]) y)))) - #; + #| ;; Old hiding mechanism never did letrec transformation (unless forced) (test-suite "Block normalization" (test-trivial-hiding/id (lambda (x y) x y)) @@ -88,94 +90,119 @@ (test-trivial-hiding (lambda (x) (id (begin (define-values (y) x) x))) (lambda (x) (begin (define-values (y) x) x))) (test-trivial-hiding (lambda (x) (define-values (y) (id x)) y) - (lambda (x) (define-values (y) x) y)))) - (test-suite "Result tests for simple hiding" + (lambda (x) (define-values (y) x) y))) + |# + ) + + (test-suite "Result tests for T hiding" (test-suite "Atomic expressions" - (test-simple-hiding/id *) - (test-simple-hiding/id 1) - (test-simple-hiding/id unbound-var)) + (test-T-hiding/id *) + (test-T-hiding/id 1) + (test-T-hiding/id unbound-var)) (test-suite "Basic expressions" - (test-simple-hiding/id (if 1 2 3)) - (test-simple-hiding/id (with-continuation-mark 1 2 3)) - (test-simple-hiding/id (define-values (x) 1)) - (test-simple-hiding/id (define-syntaxes (x) 1))) + (test-T-hiding/id (if 1 2 3)) + (test-T-hiding/id (with-continuation-mark 1 2 3)) + (test-T-hiding/id (define-values (x) 1)) + (test-T-hiding/id (define-syntaxes (x) 1))) (test-suite "Opaque macros" - (test-simple-hiding/id (id '1)) - (test-simple-hiding/id (id 1)) - (test-simple-hiding/id (id (id '1))) + (test-T-hiding/id (id '1)) + (test-T-hiding/id (id 1)) + (test-T-hiding/id (id (id '1))) ;; app is hidden: - (test-simple-hiding/id (+ '1 '2))) + (test-T-hiding/id (+ '1 '2))) (test-suite "Transparent macros" - (test-simple-hiding (Tlist x) - (list x)) - (test-simple-hiding (Tid x) x) - (test-simple-hiding (Tlist (id x)) - (list (id x))) - (test-simple-hiding (Tid (id x)) - (id x)) - (test-simple-hiding (id (Tlist x)) - (id (list x))) - (test-simple-hiding (id (Tid x)) - (id x))) + (test-T-hiding (Tlist x) + (list x)) + (test-T-hiding (Tid x) x) + (test-T-hiding (Tlist (id x)) + (list (id x))) + (test-T-hiding (Tid (id x)) + (id x)) + (test-T-hiding (id (Tlist x)) + (id (list x))) + (test-T-hiding (id (Tid x)) + (id x))) (test-suite "Blocks" - (test-simple-hiding/id (lambda (x y) x y)) - (test-simple-hiding (lambda (x y z) (begin x y) z) - (lambda (x y z) x y z)) - (test-simple-hiding/id (lambda (x y z) x (begin y z))) ;; expression begin! - (test-simple-hiding (lambda (x) (define-values (y) x) y) - (lambda (x) (letrec-values ([(y) x]) y))) - (test-simple-hiding (lambda (x) (begin (define-values (y) x)) y) - (lambda (x) (letrec-values ([(y) x]) y))) - (test-simple-hiding (lambda (x) (begin (define-values (y) x) y) x) - (lambda (x) (letrec-values ([(y) x]) y x))) - (test-simple-hiding (lambda (x) (id x)) - (lambda (x) (id x))) - (test-simple-hiding (lambda (x) (Tid x)) - (lambda (x) x)) - (test-simple-hiding/id (lambda (x) (id (define-values (y) x)) x)) - (test-simple-hiding (lambda (x) (id (define-values (y) x)) (Tid x)) - (lambda (x) (id (define-values (y) x)) x)) - (test-simple-hiding/id (lambda (x) (id (begin (define-values (y) x) x)))) - (test-simple-hiding (lambda (x) (begin (id (define-values (y) x)) y)) - (lambda (x) (id (define-values (y) x)) y)) - (test-simple-hiding (lambda (x) (id (begin (Tid (define-values (y) x)))) (Tid y)) - (lambda (x) (id (begin (define-values (y) x))) y)) - (test-simple-hiding (lambda (x) (id (begin (Tid (define-values (y) x)))) x (Tid y)) - (lambda (x) (id (begin (define-values (y) x))) x y)) - (test-simple-hiding (lambda (x) (define-values (y) (id x)) y) - (lambda (x) (letrec-values ([(y) (id x)]) y))) - (test-simple-hiding (lambda (x y) x (id y)) - (lambda (x y) x (id y))) - (test-simple-hiding (lambda (x y) x (Tid y)) - (lambda (x y) x y)) - (test-simple-hiding (lambda (x) (id (define-values (y) x)) x (Tid y)) - (lambda (x) (id (define-values (y) x)) x y)) - (test-simple-hiding/id (lambda (x) (id (define-values (y) (id x))) y)) - (test-simple-hiding (lambda (x) (id (define-values (y) (Tid x))) y) - (lambda (x) (id (define-values (y) x)) y))) + (test-T-hiding/id (lambda (x y) x y)) + (test-T-hiding (lambda (x y z) (begin x y) z) + (lambda (x y z) x y z)) + (test-T-hiding/id (lambda (x y z) x (begin y z))) ;; expression begin! + (test-T-hiding (lambda (x) (define-values (y) x) y) + (lambda (x) (letrec-values ([(y) x]) y))) + (test-T-hiding (lambda (x) (begin (define-values (y) x)) y) + (lambda (x) (letrec-values ([(y) x]) y))) + (test-T-hiding (lambda (x) (begin (define-values (y) x) y) x) + (lambda (x) (letrec-values ([(y) x]) y x))) + (test-T-hiding (lambda (x) (id x)) + (lambda (x) (id x))) + (test-T-hiding (lambda (x) (Tid x)) + (lambda (x) x)) + (test-T-hiding/id (lambda (x) (id (define-values (y) x)) x)) + (test-T-hiding (lambda (x) (id (define-values (y) x)) (Tid x)) + (lambda (x) (id (define-values (y) x)) x)) + (test-T-hiding/id (lambda (x) (id (begin (define-values (y) x) x)))) + (test-T-hiding (lambda (x) (begin (id (define-values (y) x)) y)) + (lambda (x) (id (define-values (y) x)) y)) + (test-T-hiding (lambda (x) (id (begin (Tid (define-values (y) x)))) (Tid y)) + (lambda (x) (id (begin (define-values (y) x))) y)) + (test-T-hiding (lambda (x) (id (begin (Tid (define-values (y) x)))) x (Tid y)) + (lambda (x) (id (begin (define-values (y) x))) x y)) + (test-T-hiding (lambda (x) (define-values (y) (id x)) y) + (lambda (x) (letrec-values ([(y) (id x)]) y))) + (test-T-hiding (lambda (x y) x (id y)) + (lambda (x y) x (id y))) + (test-T-hiding (lambda (x y) x (Tid y)) + (lambda (x y) x y)) + (test-T-hiding (lambda (x) (id (define-values (y) x)) x (Tid y)) + (lambda (x) (id (define-values (y) x)) x y)) + (test-T-hiding/id (lambda (x) (id (define-values (y) (id x))) y)) + (test-T-hiding (lambda (x) (id (define-values (y) (Tid x))) y) + (lambda (x) (id (define-values (y) x)) y))) (test-suite "Binding expressions" - (test-simple-hiding/id (lambda (x) x)) - (test-simple-hiding/id (lambda (x) (id x)))) + (test-T-hiding/id (lambda (x) x)) + (test-T-hiding/id (lambda (x) (id x)))) (test-suite "Module declarations" - (test-simple-hiding (module m mzscheme - (require 'helper) - (define x 1)) - (module m mzscheme - (#%module-begin - (require 'helper) - (define x 1)))) - (test-simple-hiding (module m mzscheme - (require 'helper) - (define x (Tlist 1))) - (module m mzscheme - (#%module-begin - (require 'helper) - (define x (list 1))))) - (test-simple-hiding (module m mzscheme - (#%plain-module-begin - (require 'helper) - (define x (Tlist 1)))) - (module m mzscheme - (#%plain-module-begin - (require 'helper) - (define x (list 1))))))))) + (test-T-hiding (module m mzscheme + (require 'helper) + (define x 1)) + (module m mzscheme + (require 'helper) + (define x 1))) + (test-Tm-hiding (module m mzscheme + (require 'helper) + (define x 1)) + (module m mzscheme + (#%module-begin + (require 'helper) + (define x 1)))) + + (test-T-hiding (module m mzscheme + (require 'helper) + (define x (Tlist 1))) + (module m mzscheme + (require 'helper) + (define x (list 1)))) + (test-Tm-hiding (module m mzscheme + (require 'helper) + (define x (Tlist 1))) + (module m mzscheme + (#%module-begin + (require 'helper) + (define x (list 1))))) + + (test-T-hiding (module m mzscheme + (#%plain-module-begin + (require 'helper) + (define x (Tlist 1)))) + (module m mzscheme + (#%plain-module-begin + (require 'helper) + (define x (list 1))))) + (test-Tm-hiding (module m mzscheme + (#%plain-module-begin + (require 'helper) + (define x (Tlist 1)))) + (module m mzscheme + (#%plain-module-begin + (require 'helper) + (define x (list 1))))))))) diff --git a/collects/tests/macro-debugger/tests/syntax-modules.ss b/collects/tests/macro-debugger/tests/syntax-modules.ss index 41baa45fb1..b4db2d19a3 100644 --- a/collects/tests/macro-debugger/tests/syntax-modules.ss +++ b/collects/tests/macro-debugger/tests/syntax-modules.ss @@ -18,7 +18,7 @@ [#:steps (tag-module-begin (module m '#%kernel (#%module-begin (define-values (x) 'a))))] - #:same-hidden-steps) + #:no-hidden-steps) (test "module, MB, def, use" (module m '#%kernel (#%module-begin (define-values (x) 'a) x)) #:no-steps @@ -28,7 +28,7 @@ [#:steps (tag-module-begin (module m '#%kernel (#%module-begin (define-values (x) 'a) x)))] - #:same-hidden-steps) + #:no-hidden-steps) (test "module, MB, quote" (module m '#%kernel (#%module-begin 'a)) #:no-steps @@ -37,12 +37,12 @@ (module m '#%kernel 'a) [#:steps (tag-module-begin (module m '#%kernel (#%module-begin 'a)))] - #:same-hidden-steps) + #:no-hidden-steps) (test "module, 2 quotes" (module m '#%kernel 'a 'b) [#:steps (tag-module-begin (module m '#%kernel (#%module-begin 'a 'b)))] - #:same-hidden-steps) + #:no-hidden-steps) (test "module, MB, begin" (module m '#%kernel (#%module-begin (begin 'a 'b))) [#:steps @@ -53,7 +53,7 @@ [#:steps (tag-module-begin (module m '#%kernel (#%module-begin (begin 'a 'b)))) (splice-module (module m '#%kernel (#%module-begin 'a 'b)))] - #:same-hidden-steps) + #:no-hidden-steps) (test "module, MB, def in begin" (module m '#%kernel (#%module-begin (begin (define-values (x) 'a) x))) [#:steps @@ -67,7 +67,7 @@ (module m '#%kernel (#%module-begin (begin (define-values (x) 'a) x)))) (splice-module (module m '#%kernel (#%module-begin (define-values (x) 'a) x)))] - #:same-hidden-steps) + #:no-hidden-steps) (test "module, MB, defstx, use" (module m '#%kernel @@ -106,7 +106,11 @@ (#%module-begin (#%require 'helper) 'a)))] - #:same-hidden-steps) + [#:hidden-steps + (macro + (module m '#%kernel + (#%require 'helper) + 'a))]) (test "module k+helper, defs and opaque macros" (module m '#%kernel @@ -196,14 +200,12 @@ (tag-module-begin (module m mzscheme (#%module-begin (define-values (x) 'a) x))) (macro - (module m mzscheme - (#%plain-module-begin - (#%require (for-syntax scheme/mzscheme)) - (define-values (x) 'a) - x)))] - [#:hidden-steps - (tag-module-begin - (module m mzscheme (#%module-begin (define-values (x) 'a) x)))]) + (module m mzscheme + (#%plain-module-begin + (#%require (for-syntax scheme/mzscheme)) + (define-values (x) 'a) + x)))] + #:no-hidden-steps) (test "module mz, def" (module m mzscheme (define-values (x) 'a)) [#:steps @@ -214,9 +216,7 @@ (#%plain-module-begin (#%require (for-syntax scheme/mzscheme)) (define-values (x) 'a))))] - [#:hidden-steps - (tag-module-begin - (module m mzscheme (#%module-begin (define-values (x) 'a))))]) + #:no-hidden-steps) (test "module mz, quote" (module m mzscheme 'a) [#:steps @@ -227,10 +227,8 @@ (#%plain-module-begin (#%require (for-syntax scheme/mzscheme)) 'a)))] - [#:hidden-steps - (tag-module-begin - (module m mzscheme (#%module-begin 'a)))]) - + #:no-hidden-steps) + (test "module mz, begin with 2 quotes" (module m mzscheme (begin 'a 'b)) [#:steps @@ -246,9 +244,7 @@ (#%plain-module-begin (#%require (for-syntax scheme/mzscheme)) 'a 'b)))] - [#:hidden-steps - (tag-module-begin - (module m mzscheme (#%module-begin (begin 'a 'b))))]) + #:no-hidden-steps) (test "module mz, macro use, quote" (module m mzscheme (or 'a 'b) 'c) @@ -289,9 +285,7 @@ (let-values ([(or-part) 'a]) (if or-part or-part 'b)) 'c)))] - [#:hidden-steps - (tag-module-begin - (module m mzscheme (#%module-begin (or 'a 'b) 'c)))]) + #:no-hidden-steps) (test "module mz, macro use" (module m mzscheme (or 'a 'b)) diff --git a/collects/tests/mzscheme/all.ss b/collects/tests/mzscheme/all.ss index b2a713926b..b85c0a48de 100644 --- a/collects/tests/mzscheme/all.ss +++ b/collects/tests/mzscheme/all.ss @@ -5,6 +5,5 @@ (load-relative "mzlib-tests.ss") (load-relative "syntax-tests.ss") (load-in-sandbox "version.ss") -(load-in-sandbox "net.ss") (load-in-sandbox "foreign-test.ss") (load-in-sandbox "uni-norm.ss") diff --git a/collects/tests/mzscheme/beg-adv.ss b/collects/tests/mzscheme/beg-adv.ss index 79d118494f..6430ee5e7b 100644 --- a/collects/tests/mzscheme/beg-adv.ss +++ b/collects/tests/mzscheme/beg-adv.ss @@ -221,6 +221,9 @@ (htdp-top (require (lib "unit.ss" "mzlib"))) (htdp-test #f unit? 12) (htdp-top-pop 1) +(htdp-top (require mzlib/unit)) +(htdp-test #f unit? 12) +(htdp-top-pop 1) ;; Error messages (htdp-top (define my-x 5)) @@ -236,7 +239,7 @@ (htdp-syntax-test #'define #rx"does not follow") (htdp-syntax-test #'(require) #rx"found nothing") -(htdp-syntax-test #'(require a) #rx"expected a module name as a") +(htdp-syntax-test #'(require a!) #rx"bad syntax for a module path") (htdp-syntax-test #'(require "a" "b") #rx"a single module name") (htdp-syntax-test #'(require "") #rx"empty") (htdp-syntax-test #'(require "/a") #rx"start with a slash") diff --git a/collects/tests/mzscheme/list.ss b/collects/tests/mzscheme/list.ss index ad9152bc63..ca1d8877db 100644 --- a/collects/tests/mzscheme/list.ss +++ b/collects/tests/mzscheme/list.ss @@ -263,6 +263,15 @@ (test '(1 2 3) fm values '(#f 1 #f 2 #f 3 #f)) (test '(4 8 12) fm (lambda (x) (and (even? x) (* x 2))) '(1 2 3 4 5 6))) +;; ---------- count ---------- + +(let () + (test 0 count even? '()) + (test 4 count even? '(0 2 4 6)) + (test 0 count even? '(1 3 5 7)) + (test 2 count even? '(1 2 3 4)) + (test 2 count < '(1 2 3 4) '(4 3 2 1))) + ;; ---------- append-map ---------- (let () (define am append-map) @@ -273,53 +282,53 @@ ;; ---------- argmin & argmax ---------- (let () - + (define ((check-regs . regexps) exn) (and (exn:fail? exn) (andmap (λ (reg) (regexp-match reg (exn-message exn))) regexps))) - + (test 'argmin object-name argmin) (test 1 argmin (lambda (x) 0) (list 1)) (test 1 argmin (lambda (x) x) (list 1 2 3)) (test 1 argmin (lambda (x) 1) (list 1 2 3)) - + (test 3 'argmin-makes-right-number-of-calls (let ([c 0]) (argmin (lambda (x) (set! c (+ c 1)) 0) (list 1 2 3)) c)) - + (test '(1 banana) argmin car '((3 pears) (1 banana) (2 apples))) - + (err/rt-test (argmin 1 (list 1)) (check-regs #rx"argmin" #rx"procedure")) (err/rt-test (argmin (lambda (x) x) 3) (check-regs #rx"argmin" #rx"list")) (err/rt-test (argmin (lambda (x) x) (list 1 #f)) (check-regs #rx"argmin" #rx"procedure that returns real numbers")) (err/rt-test (argmin (lambda (x) x) (list #f)) (check-regs #rx"argmin" #rx"procedure that returns real numbers")) - + (err/rt-test (argmin (lambda (x) x) (list +i)) (check-regs #rx"argmin" #rx"procedure that returns real numbers")) (err/rt-test (argmin (lambda (x) x) (list)) (check-regs #rx"argmin" #rx"non-empty list")) - + (test 'argmax object-name argmax) (test 1 argmax (lambda (x) 0) (list 1)) (test 3 argmax (lambda (x) x) (list 1 2 3)) (test 1 argmax (lambda (x) 1) (list 1 2 3)) - + (test 3 'argmax-makes-right-number-of-calls (let ([c 0]) (argmax (lambda (x) (set! c (+ c 1)) 0) (list 1 2 3)) c)) - + (test '(3 pears) argmax car '((3 pears) (1 banana) (2 apples))) - + (err/rt-test (argmax 1 (list 1)) (check-regs #rx"argmax" #rx"procedure")) (err/rt-test (argmax (lambda (x) x) 3) (check-regs #rx"argmax" #rx"list")) (err/rt-test (argmax (lambda (x) x) (list 1 #f)) (check-regs #rx"argmax" #rx"procedure that returns real numbers")) (err/rt-test (argmax (lambda (x) x) (list #f)) (check-regs #rx"argmax" #rx"procedure that returns real numbers")) - + (err/rt-test (argmax (lambda (x) x) (list +i)) (check-regs #rx"argmax" #rx"procedure that returns real numbers")) (err/rt-test (argmax (lambda (x) x) (list)) (check-regs #rx"argmax" #rx"non-empty list"))) diff --git a/collects/tests/mzscheme/macro.ss b/collects/tests/mzscheme/macro.ss index 5c9b022a05..e308ab9b05 100644 --- a/collects/tests/mzscheme/macro.ss +++ b/collects/tests/mzscheme/macro.ss @@ -144,6 +144,32 @@ (set! f 7) x))) +(test 77 'set!-transformer-prop + (let ([x 3]) + (let-syntax ([f (let () + (define-struct s!t (proc) + #:property prop:set!-transformer 0) + (make-s!t + (lambda (stx) + (syntax-case stx () + [(_ __ val) + #'(set! x val)]))))]) + (set! f 77) + x))) + +(test 777 'set!-transformer-prop2 + (let ([x 3]) + (let-syntax ([f (let () + (define-struct s!t () + #:property prop:set!-transformer + (lambda (stx) + (syntax-case stx () + [(_ __ val) + #'(set! x val)]))) + (make-s!t))]) + (set! f 777) + x))) + (test 7 'rename-transformer (let ([x 3]) (let-syntax ([f (make-rename-transformer #'x)]) @@ -415,6 +441,7 @@ [(define-values (id) rhs) (begin (syntax-local-bind-syntaxes (list #'id) #f def-ctx) + (internal-definition-context-seal def-ctx) #'(begin (define-values (id) rhs) (define-syntax handle (quote-syntax id))))] @@ -430,6 +457,85 @@ (define q 8) (nab h)) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(module rename-transformer-tests scheme/base + (require (for-syntax scheme/base)) + + (define x 12) + (define-syntax bar (let ([x 10]) + (make-rename-transformer #'x))) + (define-syntax foo (make-rename-transformer #'x)) + (list foo + (identifier-binding #'foo) + (free-identifier=? #'x #'foo)) + (identifier-binding #'bar) + + (begin-for-syntax + (define-struct rt (id) + #:property prop:rename-transformer 0 + #:omit-define-syntaxes)) + + (let-syntax ([q (make-rt #'x)]) + (list q + (identifier-binding #'q) + (free-identifier=? #'q #'x))) + + (let ([w 11]) + (letrec-syntax ([q (let () + (define-struct rt () + #:property prop:rename-transformer #'w) + (make-rt))]) + (list q + (identifier-binding #'q) + (free-identifier=? #'q #'w)))) + + (letrec-syntax ([n (make-rename-transformer #'glob)]) + (list (identifier-binding #'n) + (free-identifier=? #'n #'glob))) + + (letrec-syntax ([i (make-rename-transformer #'glob)]) + (letrec-syntax ([n (make-rename-transformer (syntax-property #'i 'not-free-identifier=? #f))]) + (list (identifier-binding #'n) + (free-identifier=? #'n #'glob))))) + +(let ([accum null]) + (parameterize ([current-print (lambda (v) + (set! accum (cons (let loop ([v v]) + (cond + [(module-path-index? v) 'mpi] + [(pair? v) (cons (loop (car v)) + (loop (cdr v)))] + [else v])) + accum)))]) + (dynamic-require ''rename-transformer-tests #f)) + (test '((#f #t) + (#f #t) + (11 lexical #t) + (12 (mpi x mpi x 0 0 0) #t) + lexical + (12 (mpi x mpi x 0 0 0) #t)) + values accum)) + +(module rename-transformer-tests:m scheme/base + (require (for-syntax scheme/base)) + (define-syntax x 1) + (define-syntax x* (make-rename-transformer #'x)) + (define-syntax x** (make-rename-transformer (syntax-property #'x 'not-free-identifier=? #t))) + (define-syntax (get stx) + (syntax-case stx () + [(_ i) + #`#,(free-identifier=? #'i #'x)])) + (provide get x* x**)) + +(module rename-transformer-tests:n scheme + (require 'rename-transformer-tests:m) + (provide go) + (define (go) + (list (get x*) (get x**)))) + +(test '(#t #f) (dynamic-require ''rename-transformer-tests:n 'go)) + ;; ---------------------------------------- (report-errs) diff --git a/collects/tests/mzscheme/module.ss b/collects/tests/mzscheme/module.ss index e3550e034e..24eba26299 100644 --- a/collects/tests/mzscheme/module.ss +++ b/collects/tests/mzscheme/module.ss @@ -236,6 +236,23 @@ (require 'p3_cr) (test 18 values w_cr) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Test `require' scoping + + +(module fake-prefix-in scheme + (require scheme/require-syntax) + (define-require-syntax (pseudo-+ stx) + (syntax-case stx () + [(_ id) + #'(only-in scheme [+ id])])) + (provide pseudo-+)) + +(require 'fake-prefix-in + (pseudo-+ ++)) +(test 12 values (++ 7 5)) + + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Test proper bindings for `#%module-begin' diff --git a/collects/tests/mzscheme/net.ss b/collects/tests/mzscheme/net.ss index 7b72211105..5d804c56e0 100644 --- a/collects/tests/mzscheme/net.ss +++ b/collects/tests/mzscheme/net.ss @@ -3,657 +3,6 @@ (Section 'net) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; url.ss tests -;; - -(require net/url - net/uri-codec - mzlib/string - ) - -(test "%Pq" uri-decode "%Pq") -(test "%P" uri-decode "%P") -(test "a=hel%2Blo+%E7%88%B8" alist->form-urlencoded '((a . "hel+lo \u7238"))) -(test '((a . "hel+lo \u7238")) form-urlencoded->alist (alist->form-urlencoded '((a . "hel+lo \u7238")))) -(test "a=hel%2Blo&b=good-bye" alist->form-urlencoded '((a . "hel+lo") (b . "good-bye"))) -(let* ([alist '((a . "hel+lo") (b . "good-bye"))] - [ampstr "a=hel%2Blo&b=good-bye"] - [semistr "a=hel%2Blo;b=good-bye"]) - (define (test:alist<->str mode str) - (parameterize ([current-alist-separator-mode - (or mode (current-alist-separator-mode))]) - (test str alist->form-urlencoded alist) - (test alist form-urlencoded->alist str))) - (test:alist<->str #f ampstr) ; the default - (test:alist<->str 'amp ampstr) - (test:alist<->str 'amp-or-semi ampstr) - (test:alist<->str 'semi semistr) - (test:alist<->str 'semi-or-amp semistr)) -(test '((x . "foo") (y . "bar") (z . "baz")) - form-urlencoded->alist "x=foo&y=bar;z=baz") -(parameterize ([current-alist-separator-mode 'semi]) - (test '((a . "hel+lo&b=good-bye")) form-urlencoded->alist - (parameterize ([current-alist-separator-mode 'amp]) - (alist->form-urlencoded '((a . "hel+lo") (b . "good-bye")))))) -(parameterize ([current-alist-separator-mode 'amp]) - (test '((a . "hel+lo;b=good-bye")) form-urlencoded->alist - (parameterize ([current-alist-separator-mode 'semi]) - (alist->form-urlencoded '((a . "hel+lo") (b . "good-bye")))))) -(test "aNt=Hi" alist->form-urlencoded '((aNt . "Hi"))) -(test '((aNt . "Hi")) form-urlencoded->alist (alist->form-urlencoded '((aNt . "Hi")))) -(test "aNt=Hi" alist->form-urlencoded (form-urlencoded->alist "aNt=Hi")) - -(test 'amp-or-semi current-alist-separator-mode) -(err/rt-test (current-alist-separator-mode 'bad)) - -;; Test the current-proxy-servers parameter can be set -(parameterize ([current-proxy-servers '(("http" "proxy.com" 3128))]) - (test '(("http" "proxy.com" 3128)) current-proxy-servers)) - -(let ([with-censor (load-relative "censor.ss")]) - (with-censor - (lambda () - ;; Test all ASCII chars - (let ([p (let loop ([n 0]) - (if (= n 128) - null - (let ([s (string (char-downcase (integer->char n)))]) - (cons (cons (string->symbol s) s) - (loop (add1 n))))))]) - (test p form-urlencoded->alist (alist->form-urlencoded p)) - (let ([l (apply string-append (map cdr p))]) - (test l uri-decode (uri-encode l))))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; tests adapted from Noel Welsh's original test suite -;; - -(let () - (define-syntax (for stx) - (syntax-case stx (code) - [(_ (i from to) e) - (and (identifier? (syntax code)) - (number? (syntax-e (syntax from))) - (number? (syntax-e (syntax to)))) - (syntax (let loop ([i from]) - e - (unless (= i to) - (loop (+ i 1)))))])) - - (test "hello" uri-encode "hello") - (test "hello%20there" uri-encode "hello there") - - (let ((pad (lambda (str) - (if (= (string-length str) 1) - (string-append "0" str) - str)))) - (for (code 0 127) - (if (or (= code 45) (= code 33) (= code 95) - (= code 46) (= code 126) (= code 42) - (= code 39) (= code 40) (= code 41) - (and (<= 48 code) (<= code 57)) ; 0-9 - (and (<= 65 code) (<= code 90)) ; A-Z - (and (<= 97 code) (<= code 122))) ; a-z - (test (string (integer->char code)) uri-encode (string (integer->char code))) - (test (string-append "%" (pad (string-upcase (number->string code 16)))) - uri-encode - (string (integer->char code)))))) - - (test "" alist->form-urlencoded '()) - (test "key=hello+there" alist->form-urlencoded '((key . "hello there"))) - (test "key1=hi&key2=hello" alist->form-urlencoded '((key1 . "hi") (key2 . "hello"))) - (test "key1=hello+there" alist->form-urlencoded '((key1 . "hello there"))) - - (test "hello" uri-decode "hello") - (test "hello there" uri-decode "hello%20there") - - (let* ((pad (lambda (str) - (if (= (string-length str) 1) - (string-append "0" str) - str))) - (uppercase (lambda (str) - (string-uppercase! str) - str)) - (lowercase (lambda (str) - (string-lowercase! str) - str)) - (hexcode (lambda (code) - (string-append "%" - (pad (number->string code 16)))))) - - ;; each of the next three of these were going from 0 to 255 in Noel's - ;; original test suite. Those fail here, however. - - (for (code 0 127) - (test (string (integer->char code)) uri-decode (uppercase (hexcode code)))) - (for (code 0 127) - (test (string (integer->char code)) uri-decode (lowercase (hexcode code))))) - - (for (code 0 127) - (test (string (integer->char code)) uri-decode (string (integer->char code)))) - - ;; form-urlencoded->alist - (test '() form-urlencoded->alist "") - (test '((key . "value")) form-urlencoded->alist "key=value") - (test '((key . "hello there")) form-urlencoded->alist "key=hello+there") - (test '((key . "a value")) form-urlencoded->alist "key=a%20value") - (test '((key . #f)) form-urlencoded->alist "key") - (test '((key1 . "value 1") (key2 . "value 2")) form-urlencoded->alist "key1=value+1&key2=value+2")) - -;; -;; end Noel's original tests -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(test "hello" uri-userinfo-encode "hello") -(test "hello%20there" uri-userinfo-encode "hello there") -(test "hello:there" uri-userinfo-encode "hello:there") -(test "hello" uri-userinfo-decode "hello") -(test "hello there" uri-userinfo-decode "hello%20there") -(test "hello:there" uri-userinfo-decode "hello:there") - - -(let () - (define (test-s->u vec str) - (test vec string->url/vec str) - (test str url/vec->string vec)) - - (define (string->url/vec str) (url->vec (string->url str))) - (define (url/vec->string vec) (url->string (vec->url vec))) - - (define (test-c-u/r expected base relative) - (define (combine-url/relative-vec x y) - (url->vec (combine-url/relative (vec->url x) y))) - (define (->vec x) (url->vec (if (string? x) (string->url x) x))) - (test (->vec expected) combine-url/relative-vec (->vec base) relative)) - - (define (vec->url vec) - (make-url (vector-ref vec 0) - (vector-ref vec 1) - (vector-ref vec 2) - (vector-ref vec 3) - (vector-ref vec 4) - (map (lambda (x) - (let ([lst (vector->list x)]) - (make-path/param (car lst) (cdr lst)))) - (vector-ref vec 5)) - (vector-ref vec 6) - (vector-ref vec 7))) - - (define (url->vec url) - (vector (url-scheme url) - (url-user url) - (url-host url) - (url-port url) - (url-path-absolute? url) - (map (lambda (x) (list->vector (cons (path/param-path x) (path/param-param x)))) - (url-path url)) - (url-query url) - (url-fragment url))) - - (test-s->u #(#f #f #f #f #t (#("")) () #f) - "/") - (test-s->u #(#f #f #f #f #f () () #f) - "") - (test-s->u #("http" #f #f #f #t (#("")) () #f) - "http:/") - - (test-s->u #("http" #f "" #f #t (#("")) () #f) - "http:///") - - (test-s->u #("http" #f "www.drscheme.org" #f #f () () #f) - "http://www.drscheme.org") - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("")) () #f) - "http://www.drscheme.org/") - - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) () #f) - "http://www.drscheme.org/a/b/c") - (test-s->u #("http" "robby" "www.drscheme.org" #f #t (#("a") #("b") #("c")) () #f) - "http://robby@www.drscheme.org/a/b/c") - (test-s->u #("http" #f "www.drscheme.org" 8080 #t (#("a") #("b") #("c")) () #f) - "http://www.drscheme.org:8080/a/b/c") - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) () "joe") - "http://www.drscheme.org/a/b/c#joe") - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tim . "")) #f) - "http://www.drscheme.org/a/b/c?tim=") - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tim . "")) "joe") - "http://www.drscheme.org/a/b/c?tim=#joe") - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tim . "tim")) "joe") - "http://www.drscheme.org/a/b/c?tim=tim#joe") - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tam . "tom")) "joe") - "http://www.drscheme.org/a/b/c?tam=tom#joe") - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tam . "tom") (pam . "pom")) "joe") - "http://www.drscheme.org/a/b/c?tam=tom&pam=pom#joe") - (parameterize ([current-alist-separator-mode 'semi]) - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tam . "tom") (pam . "pom")) "joe") - "http://www.drscheme.org/a/b/c?tam=tom;pam=pom#joe")) - (parameterize ([current-alist-separator-mode 'amp]) - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tam . "tom") (pam . "pom")) "joe") - "http://www.drscheme.org/a/b/c?tam=tom&pam=pom#joe")) - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c" "b")) () #f) - "http://www.drscheme.org/a/b/c;b") - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a" "x") #("b") #("c" "b")) () #f) - "http://www.drscheme.org/a;x/b/c;b") - - ;; test unquoting for % - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((ti#m . "")) "jo e") - "http://www.drscheme.org/a/b/c?ti%23m=#jo%20e") - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a " " a") #(" b ") #(" c ")) () #f) - "http://www.drscheme.org/a%20;%20a/%20b%20/%20c%20") - (test-s->u #("http" "robb y" "www.drscheme.org" #f #t (#("")) () #f) - "http://robb%20y@www.drscheme.org/") - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("%a") #("b/") #("c")) () #f) - "http://www.drscheme.org/%25a/b%2F/c") - (test-s->u #("http" "robby:password" "www.drscheme.org" #f #t (#("")) () #f) - "http://robby:password@www.drscheme.org/") - (test "robby:password" (lambda (x) (url-user (string->url x))) "http://robby%3apassword@www.drscheme.org/") - - ;; test the characters that need to be encoded in paths vs those that do not need to - ;; be encoded in paths - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a:@!$&'()*+,=z") #("/?#[];") #("")) () #f) - "http://www.drscheme.org/a:@!$&'()*+,=z/%2F%3F%23%5B%5D%3B/") - - (test-s->u #("http" #f "www.drscheme.org" #f #t (#(".") #("..") #(same) #(up) #("...") #("abc.def")) () #f) - "http://www.drscheme.org/%2e/%2e%2e/./../.../abc.def") - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("." "") #(".." "") #(same "") #(up "") #("..." "") #("abc.def" "")) () #f) - "http://www.drscheme.org/%2e;/%2e%2e;/.;/..;/...;/abc.def;") - - ;; test other scheme identifiers - (test-s->u #("blah" #f "www.foo.com" #f #t (#("")) () #f) - "blah://www.foo.com/") - (test-s->u #("blah99" #f "www.foo.com" #f #t (#("")) () #f) - "blah99://www.foo.com/") - (test-s->u #("blah+" #f "www.foo.com" #f #t (#("")) () #f) - "blah+://www.foo.com/") - (test-s->u #("a+b-c456.d" #f "www.foo.com" #f #t (#("")) () #f) - "a+b-c456.d://www.foo.com/") - - ;; a colon and other junk (`sub-delims') can appear in usernames - (test #("http" "x:!$&'()*+,;=y" "www.drscheme.org" #f #t (#("a")) () #f) - string->url/vec - "http://x:!$&'()*+,;=y@www.drscheme.org/a") - ;; a colon and atsign can appear in absolute paths - (test-s->u #(#f #f #f #f #t (#("x:@y") #("z")) () #f) - "/x:@y/z") - ;; and in relative paths as long as it's not in the first element - (test-s->u #(#f #f #f #f #f (#("x") #("y:@z")) () #f) - "x/y:@z") - - ;; test bad schemes - (err/rt-test (string->url "://www.foo.com/") url-exception?) - (err/rt-test (string->url "9://www.foo.com/") url-exception?) - (err/rt-test (string->url "9a://www.foo.com/") url-exception?) - (err/rt-test (string->url "a*b://www.foo.com/") url-exception?) - (err/rt-test (string->url "a b://www.foo.com/") url-exception?) - - ;; test file: urls - (test-s->u #("file" #f "" #f #t (#("abc") #("def.html")) () #f) - "file:///abc/def.html") - (test "file:///abc/def.html" url->string (string->url "file:///abc/def.html")) - (parameterize ([file-url-path-convention-type 'unix]) - (test "file://a/b" url->string (string->url "file://a/b"))) - - (parameterize ([file-url-path-convention-type 'unix]) - (test-s->u #("file" #f "localhost" #f #t (#("abc") #("def.html")) () #f) - "file://localhost/abc/def.html")) - - ;; test files: urls with colons, and the different parsing on Windows - (test-s->u #("file" #f "localhost" 123 #t (#("abc") #("def.html")) () #f) - "file://localhost:123/abc/def.html") - (parameterize ([file-url-path-convention-type 'unix]) - ;; different parse for file://foo:/... - (test #("file" #f "foo" #f #t (#("abc") #("def.html")) () #f) - string->url/vec - "file://foo:/abc/def.html")) - (parameterize ([file-url-path-convention-type 'windows]) - (test #("file" #f "" #f #t (#("foo:") #("abc") #("def.html")) () #f) - string->url/vec - "file://foo:/abc/def.html") - (test #("file" #f "" #f #t (#("c:") #("abc") #("def.html")) () #f) - string->url/vec - "file://c:/abc/def.html") - (test #("file" #f "" #f #t (#("") #("d") #("c") #("abc") #("def.html")) () #f) - string->url/vec - "file:\\\\d\\c\\abc\\def.html")) - - (parameterize ([file-url-path-convention-type 'unix]) - ;; but no effect on http://foo:/... - (test #("http" #f "foo" #f #t (#("abc") #("def.html")) () #f) - string->url/vec - "http://foo:/abc/def.html")) - (parameterize ([file-url-path-convention-type 'windows]) - (test #("http" #f "foo" #f #t (#("abc") #("def.html")) () #f) - string->url/vec - "http://foo:/abc/def.html")) - - (test "file:///c:/a/b" - url->string (path->url (bytes->path #"c:\\a\\b" 'windows))) - (test "file:///c:/a/b" - url->string (path->url (bytes->path #"\\\\?\\c:\\a\\b" 'windows))) - - (test #"/a/b/c" path->bytes - (url->path (path->url (bytes->path #"/a/b/c" 'unix)) 'unix)) - (test #"a/b/c" path->bytes - (url->path (path->url (bytes->path #"a/b/c" 'unix)) 'unix)) - (test #"c:\\a\\b" path->bytes - (url->path (path->url (bytes->path #"c:/a/b" 'windows)) 'windows)) - (test #"a\\b" path->bytes - (url->path (path->url (bytes->path #"a/b" 'windows)) 'windows)) - (test #"\\\\d\\c\\a" path->bytes - (url->path (path->url (bytes->path #"//d/c/a" 'windows)) 'windows)) - (test #"c:\\a\\b" path->bytes - (url->path (path->url (bytes->path #"\\\\?\\c:\\a\\b" 'windows)) 'windows)) - (test #"\\\\d\\c\\a\\b" path->bytes - (url->path (path->url (bytes->path #"\\\\?\\UNC\\d\\c\\a\\b" 'windows)) 'windows)) - (test #"\\\\?\\c:\\a/x\\b" path->bytes - (url->path (path->url (bytes->path #"\\\\?\\c:\\a/x\\b" 'windows)) 'windows)) - (test #"\\\\?\\UNC\\d\\c\\a/x\\b" path->bytes - (url->path (path->url (bytes->path #"\\\\?\\UNC\\d\\\\c\\a/x\\b" 'windows)) 'windows)) - - ;; see PR8809 (value-less keys in the query part) - (test-s->u #("http" #f "foo.bar" #f #t (#("baz")) ((ugh . #f)) #f) - "http://foo.bar/baz?ugh") - (test-s->u #("http" #f "foo.bar" #f #t (#("baz")) ((ugh . "")) #f) - "http://foo.bar/baz?ugh=") - (test-s->u #("http" #f "foo.bar" #f #t (#("baz")) ((ugh . #f) (x . "y") (|1| . "2")) #f) - "http://foo.bar/baz?ugh&x=y&1=2") - (test-s->u #("http" #f "foo.bar" #f #t (#("baz")) ((ugh . "") (x . "y") (|1| . "2")) #f) - "http://foo.bar/baz?ugh=&x=y&1=2") - (parameterize ([current-alist-separator-mode 'amp]) - (test-s->u #("http" #f "foo.bar" #f #t (#("baz")) ((ugh . #f) (x . "y") (|1| . "2")) #f) - "http://foo.bar/baz?ugh&x=y&1=2")) - (parameterize ([current-alist-separator-mode 'semi]) - (test-s->u #("http" #f "foo.bar" #f #t (#("baz")) ((ugh . #f) (x . "y") (|1| . "2")) #f) - "http://foo.bar/baz?ugh;x=y;1=2")) - - ;; test case sensitivity - (test #("http" "ROBBY" "www.drscheme.org" 80 #t (#("INDEX.HTML" "XXX")) ((T . "P")) "YYY") - string->url/vec - "HTTP://ROBBY@WWW.DRSCHEME.ORG:80/INDEX.HTML;XXX?T=P#YYY") - - (test-s->u #("mailto" #f #f #f #f (#("robby@plt-scheme.org")) () #f) - "mailto:robby@plt-scheme.org") - - (test #("http" #f "www.drscheme.org" #f #f () ((bar . "馨慧")) #f) - string->url/vec - "http://www.drscheme.org?bar=馨慧") - - (test #("http" #f "www.drscheme.org" #f #f () ((bár . "é")) #f) - string->url/vec - "http://www.drscheme.org?bár=é") - - (test-c-u/r "http://www.drscheme.org" - (make-url #f #f #f #f #f '() '() #f) - "http://www.drscheme.org") - - (test-c-u/r "http://www.drscheme.org" - "http://www.drscheme.org" - "") - - (test-c-u/r "http://www.mzscheme.org" - "http://www.drscheme.org/" - "http://www.mzscheme.org") - - (test-c-u/r "http://www.drscheme.org/index.html" - "http://www.drscheme.org/" - "index.html") - (test-c-u/r "http://www.drscheme.org/index.html" - "http://www.drscheme.org/" - "/index.html") - (test-c-u/r "http://www.drscheme.org/index.html" - "http://www.drscheme.org/a/b/c/" - "/index.html") - (test-c-u/r "http://www.drscheme.org/a/b/index.html" - "http://www.drscheme.org/a/b/c" - "index.html") - (test-c-u/r "http://www.drscheme.org/a/b/c/index.html" - "http://www.drscheme.org/a/b/c/" - "index.html") - (test-c-u/r "http://www.drscheme.org/a/b/d/index.html" - "http://www.drscheme.org/a/b/c" - "d/index.html") - (test-c-u/r "http://www.drscheme.org/a/b/c/d/index.html" - "http://www.drscheme.org/a/b/c/" - "d/index.html") - (test-c-u/r "http://www.drscheme.org/a/b/index.html" - "http://www.drscheme.org/a/b/c/" - "../index.html") - (test-c-u/r "http://www.drscheme.org/a/b/c/index.html" - "http://www.drscheme.org/a/b/c/" - "./index.html") - (test-c-u/r "http://www.drscheme.org/a/b/c/%2e%2e/index.html" - "http://www.drscheme.org/a/b/c/" - "%2e%2e/index.html") - (test-c-u/r "http://www.drscheme.org/a/index.html" - "http://www.drscheme.org/a/b/../c/" - "../index.html") - - (test-c-u/r "http://www.drscheme.org/a/b/c/d/index.html" - "http://www.drscheme.org/a/b/c/d/index.html#ghijkl" - "index.html") - (test-c-u/r "http://www.drscheme.org/a/b/c/d/index.html#abcdef" - "http://www.drscheme.org/a/b/c/d/index.html#ghijkl" - "#abcdef") - - (test-c-u/r "file:///a/b/c/d/index.html" - "file:///a/b/c/" - "d/index.html") - (test-c-u/r "file:///a/b/d/index.html" - "file:///a/b/c" - "d/index.html") - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; tests from rfc 3986 - ;; - - (for-each - (λ (line) (test-c-u/r (caddr line) "http://a/b/c/d;p?q" (car line))) - '(("g:h" = "g:h") - ("g" = "http://a/b/c/g") - ("./g" = "http://a/b/c/g") - ("g/" = "http://a/b/c/g/") - ("/g" = "http://a/g") - ("//g" = "http://g") - ("?y" = "http://a/b/c/d;p?y") - ("g?y" = "http://a/b/c/g?y") - ("#s" = "http://a/b/c/d;p?q#s") - ("g#s" = "http://a/b/c/g#s") - ("g?y#s" = "http://a/b/c/g?y#s") - (";x" = "http://a/b/c/;x") - ("g;x" = "http://a/b/c/g;x") - ("g;x?y#s" = "http://a/b/c/g;x?y#s") - ("" = "http://a/b/c/d;p?q") - ("." = "http://a/b/c/") - ("./" = "http://a/b/c/") - (".." = "http://a/b/") - ("../" = "http://a/b/") - ("../g" = "http://a/b/g") - ("../.." = "http://a/") - ("../../" = "http://a/") - ("../../g" = "http://a/g") - - ;; abnormal examples follow - - ("../../../g" = "http://a/g") - ("../../../../g" = "http://a/g") - - ("/./g" = "http://a/g") - ("/../g" = "http://a/g") - ("g." = "http://a/b/c/g.") - (".g" = "http://a/b/c/.g") - ("g.." = "http://a/b/c/g..") - ("..g" = "http://a/b/c/..g") - - ("./../g" = "http://a/b/g") - ("./g/." = "http://a/b/c/g/") - ("g/./h" = "http://a/b/c/g/h") - ("g/../h" = "http://a/b/c/h") - ("g;x=1/./y" = "http://a/b/c/g;x=1/y") - ("g;x=1/../y" = "http://a/b/c/y") - - ("g?y/./x" = "http://a/b/c/g?y/./x") - ("g?y/../x" = "http://a/b/c/g?y/../x") - ("g#s/./x" = "http://a/b/c/g#s/./x") - ("g#s/../x" = "http://a/b/c/g#s/../x") - ("http:g" = "http:g") ; for strict parsers - - )) - - ) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; a few tests of head.ss -- JBC, 2006-07-31 -;; - -(require net/head) - -(test (void) validate-header "From: me@here.net\r\n\r\n") -(test (void) validate-header #"From: me@here.net\r\n\r\n") -(test (void) validate-header "From: a\r\nTo: b\r\nResent-to: qrv@erocg\r\n\r\n") -(test (void) validate-header #"From: a\r\nTo: b\r\nResent-to: qrv@erocg\r\n\r\n") -(err/rt-test (validate-header "From: a\r\nTo: b\r\nMissingTrailingrn: qrv@erocg\r\n") exn:fail?) -(err/rt-test (validate-header #"From: a\r\nTo: b\r\nMissingTrailingrn: qrv@erocg\r\n") exn:fail?) -(err/rt-test (validate-header "From: a\r\nnocolon inthisline\r\n\r\n") exn:fail?) -(err/rt-test (validate-header #"From: a\r\nnocolon inthisline\r\n\r\n") exn:fail?) -(err/rt-test (validate-header "From: a\r\nMissingReturn: och\n\r\n" exn:fail?)) -(err/rt-test (validate-header #"From: a\r\nMissingReturn: och\n\r\n" exn:fail?)) -(err/rt-test (validate-header "From: a\r\nSpacein Fieldname: och\r\n\r\n" exn:fail?)) -(err/rt-test (validate-header #"From: a\r\nSpacein Fieldname: och\r\n\r\n" exn:fail?)) - -(define test-header "From: abc\r\nTo: field is\r\n continued\r\nAnother: zoo\r\n continued\r\n\r\n") -(define test-header/bytes #"From: abc\r\nTo: field is\r\n continued\r\nAnother: zoo\r\n continued\r\n\r\n") - -(test "abc" extract-field "From" test-header) -(test #"abc" extract-field #"From" test-header/bytes) -(test "field is\r\n continued" extract-field "To" test-header) -(test #"field is\r\n continued" extract-field #"To" test-header/bytes) -(test "zoo\r\n continued" extract-field "Another" test-header) -(test #"zoo\r\n continued" extract-field #"Another" test-header/bytes) - -(test "From: def\r\nTo: field is\r\n continued\r\nAnother: zoo\r\n continued\r\n\r\n" - replace-field "From" "def" test-header) -(test #"From: def\r\nTo: field is\r\n continued\r\nAnother: zoo\r\n continued\r\n\r\n" - replace-field #"From" #"def" test-header/bytes) -(test "To: field is\r\n continued\r\nAnother: zoo\r\n continued\r\n\r\n" - replace-field "From" #f test-header) -(test #"To: field is\r\n continued\r\nAnother: zoo\r\n continued\r\n\r\n" - replace-field #"From" #f test-header/bytes) - -(test "From: abc\r\nTo: qrs\r\nAnother: zoo\r\n continued\r\n\r\n" - replace-field "To" "qrs" test-header) -(test #"From: abc\r\nTo: qrs\r\nAnother: zoo\r\n continued\r\n\r\n" - replace-field #"To" #"qrs" test-header/bytes) -(test "From: abc\r\nAnother: zoo\r\n continued\r\n\r\n" - replace-field "To" #f test-header) -(test #"From: abc\r\nAnother: zoo\r\n continued\r\n\r\n" - replace-field #"To" #f test-header/bytes) - -(test "From: abc\r\nTo: field is\r\n continued\r\nAnother: abc\r\n def\r\n\r\n" - replace-field "Another" "abc\r\n def" test-header) -(test #"From: abc\r\nTo: field is\r\n continued\r\nAnother: abc\r\n def\r\n\r\n" - replace-field #"Another" #"abc\r\n def" test-header/bytes) -(test "From: abc\r\nTo: field is\r\n continued\r\n\r\n" - replace-field "Another" #f test-header) -(test #"From: abc\r\nTo: field is\r\n continued\r\n\r\n" - replace-field #"Another" #f test-header/bytes) - -(test "From: abc\r\nAnother: zoo\r\n continued\r\n\r\n" - remove-field "To" test-header) -(test #"From: abc\r\nAnother: zoo\r\n continued\r\n\r\n" - remove-field #"To" test-header/bytes) - -(test `(("From" . "abc") - ("To" . "field is\r\n continued") - ("Another" . "zoo\r\n continued")) - extract-all-fields test-header) -(test `((#"From" . #"abc") - (#"To" . #"field is\r\n continued") - (#"Another" . #"zoo\r\n continued")) - extract-all-fields test-header/bytes) - -(test "From: abc\r\nTo: field is\r\n continued\r\nAnother: zoo\r\n continued\r\nAthird: data\r\n\r\n" - append-headers test-header "Athird: data\r\n\r\n") -(test #"From: abc\r\nTo: field is\r\n continued\r\nAnother: zoo\r\n continued\r\nAthird: data\r\n\r\n" - append-headers test-header/bytes #"Athird: data\r\n\r\n") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; cookie tests --- JBM, 2006-12-01 - -(require net/cookie) - -;; cookie-test : (cookie -> cookie) string -> test -(define (cookie-test fn expected) - (test expected - (λ (c) (print-cookie (fn c))) - (set-cookie "a" "b"))) - -;; RC = "reverse curry" -(define (RC f arg2) (λ (arg1) (f arg1 arg2))) -;; o = compose -(define-syntax o - (syntax-rules () - [(o f) f] - [(o f g h ...) - (λ (x) (o/* x f g h ...))])) -(define-syntax o/* - (syntax-rules () - [(o/* x) x] - [(o/* x f g ...) - (f (o/* x g ...))])) - -;; test the most basic functionality -(cookie-test (λ (x) x) "a=b; Version=1") - -;; test each modifier individually -(cookie-test (RC cookie:add-comment "set+a+to+b") "a=b; Comment=set+a+to+b; Version=1") -(cookie-test (RC cookie:add-comment "a comment with spaces") "a=b; Comment=\"a comment with spaces\"; Version=1") -(cookie-test (RC cookie:add-comment "the \"risks\" involved in waking") - "a=b; Comment=\"the \\\"risks\\\" involved in waking\"; Version=1") -(cookie-test (RC cookie:add-comment "\"already formatted\"") - "a=b; Comment=\"already formatted\"; Version=1") -(cookie-test (RC cookie:add-comment "\"problematic \" internal quote\"") - "a=b; Comment=\"\\\"problematic \\\" internal quote\\\"\"; Version=1") -(cookie-test (RC cookie:add-comment "contains;semicolon") - "a=b; Comment=\"contains;semicolon\"; Version=1") -(cookie-test (RC cookie:add-domain ".example.net") "a=b; Domain=.example.net; Version=1") -(cookie-test (RC cookie:add-max-age 100) "a=b; Max-Age=100; Version=1") -(cookie-test (RC cookie:add-path "/whatever/wherever/") "a=b; Path=\"/whatever/wherever/\"; Version=1") -(cookie-test (RC cookie:add-path "a+path") "a=b; Path=a+path; Version=1") -(cookie-test (RC cookie:add-path "\"/already/quoted/\"") "a=b; Path=\"/already/quoted/\"; Version=1") -(cookie-test (RC cookie:secure #t) "a=b; Secure; Version=1") -(cookie-test (RC cookie:secure #f) "a=b; Version=1") -(cookie-test (RC cookie:version 12) "a=b; Version=12") - -;; test combinations -(cookie-test (o (RC cookie:add-comment "set+a+to+b") - (RC cookie:add-domain ".example.net")) - "a=b; Comment=set+a+to+b; Domain=.example.net; Version=1") -(cookie-test (o (RC cookie:add-max-age 300) - (RC cookie:secure #t)) - "a=b; Max-Age=300; Secure; Version=1") -(cookie-test (o (RC cookie:add-path "/whatever/wherever/") - (RC cookie:version 10) - (RC cookie:add-max-age 20)) - "a=b; Max-Age=20; Path=\"/whatever/wherever/\"; Version=10") - -;; test error cases -(define-syntax cookie-error-test - (syntax-rules () - [(cookie-error-test e) - (thunk-error-test (λ () (e (set-cookie "a" "b"))) #'e cookie-error?)])) - -(cookie-error-test (RC cookie:add-comment "illegal character #\000")) -(cookie-error-test (RC cookie:add-max-age -10)) -(cookie-error-test (RC cookie:add-domain "doesntstartwithadot.example.com")) -(cookie-error-test (RC cookie:add-domain "bad domain.com")) -(cookie-error-test (RC cookie:add-domain ".bad-domain;com")) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; other net tests @@ -663,115 +12,4 @@ net/qp mzlib/port) -(define tricky-strings - (let ([dir (collection-path "tests" "mzscheme")]) - (list (make-bytes 200 32) - (make-bytes 200 9) - (make-bytes 200 (char->integer #\x)) - (make-bytes 201 (char->integer #\x)) - (make-bytes 202 (char->integer #\x)) - (make-bytes 203 (char->integer #\x)) - (make-bytes 204 (char->integer #\x)) - (list->bytes - (let loop ([i 0]) - (if (= i 256) - null - (cons i (loop (add1 i)))))) - ;; Something that doesn't end with a LF: - (bytes-append (with-input-from-file (build-path dir "net.ss") - (lambda () (read-bytes 500))) - #"xxx") - ;; CRLF: - (regexp-replace #rx#"\r?\n" - (with-input-from-file (build-path dir "net.ss") - (lambda () (read-bytes 500))) - #"\r\n")))) - -(define (check-same encode decode port line-rx max-w) - (let ([p (open-output-bytes)]) - (copy-port port p) - (let ([bytes (get-output-bytes p)] - [r (open-output-bytes)]) - (encode (open-input-bytes bytes) r) - (let ([p (open-input-bytes (get-output-bytes r))]) - (let loop () - (let ([l (read-bytes-line p 'any)]) - (unless (eof-object? l) - (unless (<= (bytes-length l) max-w) - (test encode "line too long" l)) - (let ([m (regexp-match-positions line-rx l)]) - (unless (and m (= (bytes-length l) (cdar m))) - (test encode 'bad-line l))) - (loop)))) - (let ([q (open-output-bytes)]) - (decode (open-input-bytes (get-output-bytes r)) q) - (unless (equal? (get-output-bytes q) bytes) - (with-output-to-file "/tmp/x0" (lambda () (display (get-output-bytes r))) 'truncate) - (with-output-to-file "/tmp/x1" (lambda () (display (get-output-bytes q))) 'truncate) - (with-output-to-file "/tmp/x2" (lambda () (display bytes)) 'truncate) - (error 'decode "failed"))))))) - -(define ((check-same-file encode decode line-rx max-w) file) - ;; This "test" is really just a progress report: - (test #t list? (list file encode)) - (call-with-input-file file - (lambda (p) (check-same encode decode p line-rx max-w)))) - -(define (check-same-all encode decode line-rx max-w) - (for-each (lambda (tricky-string) - (check-same encode decode - (open-input-bytes tricky-string) - line-rx max-w)) - tricky-strings) - (let* ([dir (collection-path "tests" "mzscheme")] - [files (filter-map (lambda (f) - ;; check 1/3 of the files, randomly - (let ([p (build-path dir f)]) - (and (zero? (random 3)) - (not (regexp-match - #rx"^flat.*\\.ss$" - (path-element->string f))) - (file-exists? p) - p))) - (directory-list dir))]) - (for-each (check-same-file encode decode line-rx max-w) files))) - -(check-same-all (lambda (i o) (qp-encode-stream i o)) - qp-decode-stream - #rx#"^(|[\t \41-\176]*[\41-\176]+)$" - 76) - -(check-same-all base64-encode-stream - base64-decode-stream - #rx#"^[0-9a-zA-Z+=/]*$" - 72) - -#| -Use this to compare base64 encode/decode against the unix utilities -(require net/base64 scheme/system) -(define (base64-encode* bstr) - (let ([o (open-output-bytes)]) - (parameterize ([current-output-port o] - [current-input-port (open-input-bytes bstr)]) - (system "base64-encode")) - (let* ([o (get-output-bytes o)] - [o (regexp-replace #rx#"(.)(?:\r?\n)?$" o #"\\1\r\n")] - [o (regexp-replace* #rx#"\r?\n" o #"\r\n")]) - o))) -(define (base64-decode* bstr) - (let ([o (open-output-bytes)]) - (parameterize ([current-output-port o] - [current-input-port (open-input-bytes bstr)]) - (system "base64-decode")) - (get-output-bytes o))) -(define (check-base64-encode bstr) - (equal? (base64-encode bstr) (base64-encode* bstr))) -(define (check-base64-decode bstr) - (equal? (base64-decode bstr) (base64-decode* bstr))) -(define (check-base64-both bstr) - (let ([en (base64-encode bstr)]) - (and (equal? en (base64-encode* bstr)) - (equal? (base64-decode en) (base64-decode* en))))) -|# - (report-errs) diff --git a/collects/tests/mzscheme/syntax.ss b/collects/tests/mzscheme/syntax.ss index cb38db8f37..c9f7b6a1ad 100644 --- a/collects/tests/mzscheme/syntax.ss +++ b/collects/tests/mzscheme/syntax.ss @@ -1203,7 +1203,123 @@ (define x 10)) (abcdefg))) + +;; ---------------------------------------- + +(test 79 'splicing-let (let () + (splicing-let ([x 79]) + (define (y) x)) + (y))) +(test 77 'splicing-let (let () + (define q 77) + (splicing-let ([q 8] + [x q]) + (define (z) x)) + (z))) +(test 81 'splicing-letrec (let () + (define q 77) + (splicing-letrec ([q 81] + [x q]) + (define (z) x)) + (z))) +(test 82 'splicing-letrec (let () + (define q 77) + (splicing-letrec ([x (lambda () (q))] + [q (lambda () 82)]) + (define (z) x)) + ((z)))) +(test 81 'splicing-letrec (eval + '(begin + (define q 77) + (splicing-letrec ([q 81] + [x q]) + (define (z) x)) + (z)))) +(test 82 'splicing-letrec (eval + '(begin + (define q 77) + (splicing-letrec ([x (lambda () (q))] + [q (lambda () 82)]) + (define (z) x)) + ((z))))) +(err/rt-test (eval + '(begin + (splicing-letrec ([x q] + [q 81]) + x))) + exn:fail:contract:variable?) + +(test 82 'splicing-letrec-syntaxes+values + (let () + (define q 77) + (splicing-letrec-syntaxes+values + ([(mx) (lambda (stx) (quote-syntax (x)))] + [(m) (lambda (stx) (quote-syntax (mx)))]) + ([(x) (lambda () (q))] + [(q) (lambda () 82)]) + (define (a) (m))) + (a))) + +(test 82 'splicing-letrec-syntaxes+values + (eval + '(begin + (define q 77) + (splicing-letrec-syntaxes+values + ([(mx) (lambda (stx) (quote-syntax (x)))] + [(m) (lambda (stx) (quote-syntax (mx)))]) + ([(x) (lambda () (q))] + [(q) (lambda () 82)]) + (define (a) (m))) + (a)))) + +(test 82 'splicing-local + (let () + (define (x) q) + (define q 77) + (define-syntax (m stx) (quote-syntax (x))) + (splicing-local + [(define-syntax (m stx) (quote-syntax (mx))) + (define (x) (q)) + (define-syntax (mx stx) (quote-syntax (x))) + (define (q) 82)] + (define (a) (m))) + (a))) + +(test 82 'splicing-local + (eval + '(begin + (define (x) q) + (define q 77) + (define-syntax (m stx) (quote-syntax (x))) + (splicing-local + [(define-syntax (m stx) (quote-syntax (mx))) + (define (x) (q)) + (define-syntax (mx stx) (quote-syntax (x))) + (define (q) 82)] + (define (a) (m))) + (a)))) + +;; local names are not visible outside +(test 77 'splicing-local + (let () + (define q 77) + (define-syntax (m stx) (quote-syntax (x))) + (splicing-local + [(define-syntax (m stx) (quote-syntax (q))) + (define (q) 82)] + (define (a) (m))) + (m))) +(test 77 'splicing-local + (eval + '(begin + (define q 77) + (define-syntax (m stx) (quote-syntax (x))) + (splicing-local + [(define-syntax (m stx) (quote-syntax (q))) + (define (q) 82)] + (define (a) (m))) + (m)))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) - diff --git a/collects/tests/net/cgi.ss b/collects/tests/net/cgi.ss new file mode 100644 index 0000000000..9f6eb2e2ff --- /dev/null +++ b/collects/tests/net/cgi.ss @@ -0,0 +1,22 @@ +#lang scheme +(require net/cgi (only-in net/uri-codec current-alist-separator-mode) + tests/eli-tester) + +(define (test-bindings mode query-string) + (parameterize ([current-alist-separator-mode mode]) + (putenv "QUERY_STRING" query-string) + (get-bindings))) + +(provide tests) +(define (tests) + (putenv "REQUEST_METHOD" "GET") + (test (test-bindings 'amp-or-semi "key1=value1&key2=value2;key3=value3") + => '([key1 . "value1"] [key2 . "value2"] [key3 . "value3"]) + (test-bindings 'amp "key1=value1&key2=value2") + => '([key1 . "value1"] [key2 . "value2"]) + (test-bindings 'amp "key1=value1;key2=value2") + => '([key1 . "value1;key2=value2"]) + (test-bindings 'semi "key1=value1;key2=value2") + => '([key1 . "value1"] [key2 . "value2"]) + (test-bindings 'semi "key1=value1&key2=value2") + => '([key1 . "value1&key2=value2"]))) diff --git a/collects/tests/net/cookie.ss b/collects/tests/net/cookie.ss new file mode 100644 index 0000000000..601eb3d71f --- /dev/null +++ b/collects/tests/net/cookie.ss @@ -0,0 +1,84 @@ +#lang scheme +(require net/cookie tests/eli-tester) + +;; cookie tests --- JBM, 2006-12-01 + +(provide tests) +(define (tests) + ;; cookie-test : (cookie -> cookie) string -> test + (define (cookie-test fn expected) + (test (print-cookie (fn (set-cookie "a" "b"))) => expected)) + ;; RC = "reverse curry" + (define (RC f arg2) (λ (arg1) (f arg1 arg2))) + ;; o = compose + (define-syntax o + (syntax-rules () + [(o f) f] + [(o f g h ...) (λ (x) (o/* x f g h ...))])) + (define-syntax o/* + (syntax-rules () + [(o/* x) x] + [(o/* x f g ...) (f (o/* x g ...))])) + + (define (tests) + + ;; test the most basic functionality + (cookie-test (λ (x) x) "a=b; Version=1") + + ;; test each modifier individually + (cookie-test (RC cookie:add-comment "set+a+to+b") + "a=b; Comment=set+a+to+b; Version=1") + (cookie-test (RC cookie:add-comment "a comment with spaces") + "a=b; Comment=\"a comment with spaces\"; Version=1") + (cookie-test (RC cookie:add-comment "the \"risks\" involved in waking") + "a=b; Comment=\"the \\\"risks\\\" involved in waking\"; Version=1") + (cookie-test (RC cookie:add-comment "\"already formatted\"") + "a=b; Comment=\"already formatted\"; Version=1") + (cookie-test (RC cookie:add-comment "\"problematic \" internal quote\"") + "a=b; Comment=\"\\\"problematic \\\" internal quote\\\"\"; Version=1") + (cookie-test (RC cookie:add-comment "contains;semicolon") + "a=b; Comment=\"contains;semicolon\"; Version=1") + (cookie-test (RC cookie:add-domain ".example.net") + "a=b; Domain=.example.net; Version=1") + (cookie-test (RC cookie:add-max-age 100) + "a=b; Max-Age=100; Version=1") + (cookie-test (RC cookie:add-path "/whatever/wherever/") + "a=b; Path=\"/whatever/wherever/\"; Version=1") + (cookie-test (RC cookie:add-path "a+path") + "a=b; Path=a+path; Version=1") + (cookie-test (RC cookie:add-path "\"/already/quoted/\"") + "a=b; Path=\"/already/quoted/\"; Version=1") + (cookie-test (RC cookie:secure #t) + "a=b; Secure; Version=1") + (cookie-test (RC cookie:secure #f) + "a=b; Version=1") + (cookie-test (RC cookie:version 12) + "a=b; Version=12") + + ;; test combinations + (cookie-test (o (RC cookie:add-comment "set+a+to+b") + (RC cookie:add-domain ".example.net")) + "a=b; Comment=set+a+to+b; Domain=.example.net; Version=1") + (cookie-test (o (RC cookie:add-max-age 300) + (RC cookie:secure #t)) + "a=b; Max-Age=300; Secure; Version=1") + (cookie-test (o (RC cookie:add-path "/whatever/wherever/") + (RC cookie:version 10) + (RC cookie:add-max-age 20)) + "a=b; Max-Age=20; Path=\"/whatever/wherever/\"; Version=10") + + ;; test error cases + (let () + (define-syntax cookie-error-test + (syntax-rules () + [(cookie-error-test e) + (test (e (set-cookie "a" "b")) =error> cookie-error?)])) + (cookie-error-test (RC cookie:add-comment "illegal character #\000")) + (cookie-error-test (RC cookie:add-max-age -10)) + (cookie-error-test (RC cookie:add-domain "doesntstartwithadot.example.com")) + (cookie-error-test (RC cookie:add-domain "bad domain.com")) + (cookie-error-test (RC cookie:add-domain ".bad-domain;com"))) + + ) + + (test do (tests))) diff --git a/collects/tests/net/encoders.ss b/collects/tests/net/encoders.ss new file mode 100644 index 0000000000..3d06130db2 --- /dev/null +++ b/collects/tests/net/encoders.ss @@ -0,0 +1,109 @@ +#lang scheme +(require net/base64 net/qp tests/eli-tester) + +(define tricky-strings + (let ([dir (collection-path "tests" "mzscheme")]) + (list (make-bytes 200 32) + (make-bytes 200 9) + (make-bytes 200 (char->integer #\x)) + (make-bytes 201 (char->integer #\x)) + (make-bytes 202 (char->integer #\x)) + (make-bytes 203 (char->integer #\x)) + (make-bytes 204 (char->integer #\x)) + (list->bytes (for/list ([i (in-range 256)]) i)) + ;; Something that doesn't end with a LF: + (bytes-append (with-input-from-file (build-path dir "net.ss") + (lambda () (read-bytes 500))) + #"xxx") + ;; CRLF: + (regexp-replace #rx#"\r?\n" + (with-input-from-file (build-path dir "net.ss") + (lambda () (read-bytes 500))) + #"\r\n")))) + +(define (check-same encode decode port line-rx max-w) + (let ([p (open-output-bytes)]) + (copy-port port p) + (let ([bytes (get-output-bytes p)] + [r (open-output-bytes)]) + (encode (open-input-bytes bytes) r) + (let ([p (open-input-bytes (get-output-bytes r))]) + (let loop () + (let ([l (read-bytes-line p 'any)]) + (unless (eof-object? l) + (test ; #:failure-message (format "line too long; ~s" encode) + (<= (bytes-length l) max-w)) + (let ([m (regexp-match-positions line-rx l)]) + (test ; #:failure-message (format "bad line; ~s" encode) + (and m (= (bytes-length l) (cdar m))))) + (loop)))) + (let ([q (open-output-bytes)]) + (decode (open-input-bytes (get-output-bytes r)) q) + (unless (equal? (get-output-bytes q) bytes) + (with-output-to-file "/tmp/x0" (lambda () (display (get-output-bytes r))) 'truncate) + (with-output-to-file "/tmp/x1" (lambda () (display (get-output-bytes q))) 'truncate) + (with-output-to-file "/tmp/x2" (lambda () (display bytes)) 'truncate) + (error 'decode "failed"))))))) + +(define ((check-same-file encode decode line-rx max-w) file) + (call-with-input-file file + (lambda (p) (check-same encode decode p line-rx max-w)))) + +(define (check-same-all encode decode line-rx max-w) + (for-each (lambda (tricky-string) + (check-same encode decode + (open-input-bytes tricky-string) + line-rx max-w)) + tricky-strings) + (let* ([dir (collection-path "tests" "mzscheme")] + [files (filter-map + (lambda (f) + ;; check 1/4 of the files, randomly + (let ([p (build-path dir f)]) + (and (zero? (random 4)) + (not (regexp-match #rx"^flat.*\\.ss$" + (path-element->string f))) + (file-exists? p) + p))) + (directory-list dir))]) + (for-each (check-same-file encode decode line-rx max-w) files))) + +(provide tests) +(define (tests) + (test + do (check-same-all (lambda (i o) (qp-encode-stream i o)) + qp-decode-stream + #rx#"^(|[\t \41-\176]*[\41-\176]+)$" + 76) + do (check-same-all base64-encode-stream + base64-decode-stream + #rx#"^[0-9a-zA-Z+=/]*$" + 72))) + +#| +Use this to compare base64 encode/decode against the unix utilities +(require net/base64 scheme/system) +(define (base64-encode* bstr) + (let ([o (open-output-bytes)]) + (parameterize ([current-output-port o] + [current-input-port (open-input-bytes bstr)]) + (system "base64-encode")) + (let* ([o (get-output-bytes o)] + [o (regexp-replace #rx#"(.)(?:\r?\n)?$" o #"\\1\r\n")] + [o (regexp-replace* #rx#"\r?\n" o #"\r\n")]) + o))) +(define (base64-decode* bstr) + (let ([o (open-output-bytes)]) + (parameterize ([current-output-port o] + [current-input-port (open-input-bytes bstr)]) + (system "base64-decode")) + (get-output-bytes o))) +(define (check-base64-encode bstr) + (equal? (base64-encode bstr) (base64-encode* bstr))) +(define (check-base64-decode bstr) + (equal? (base64-decode bstr) (base64-decode* bstr))) +(define (check-base64-both bstr) + (let ([en (base64-encode bstr)]) + (and (equal? en (base64-encode* bstr)) + (equal? (base64-decode en) (base64-decode* en))))) +|# diff --git a/collects/tests/net/head.ss b/collects/tests/net/head.ss new file mode 100644 index 0000000000..63df83896d --- /dev/null +++ b/collects/tests/net/head.ss @@ -0,0 +1,93 @@ +#lang scheme +(require net/head tests/eli-tester) + +;; a few tests of head.ss -- JBC, 2006-07-31 + +(provide tests) +(define (tests) + (define test-header + (string-append "From: abc\r\nTo: field is\r\n continued\r\n" + "Another: zoo\r\n continued\r\n\r\n")) + (define test-header/bytes + (bytes-append #"From: abc\r\nTo: field is\r\n continued\r\n" + #"Another: zoo\r\n continued\r\n\r\n")) + (test + + (validate-header "From: me@here.net\r\n\r\n") + (validate-header #"From: me@here.net\r\n\r\n") + (validate-header "From: a\r\nTo: b\r\nResent-to: qrv@erocg\r\n\r\n") + (validate-header #"From: a\r\nTo: b\r\nResent-to: qrv@erocg\r\n\r\n") + + (validate-header "From: a\r\nTo: b\r\nMissingTrailingrn: qrv@erocg\r\n") + =error> "missing ending CRLF" + (validate-header #"From: a\r\nTo: b\r\nMissingTrailingrn: qrv@erocg\r\n") + =error> "missing ending CRLF" + (validate-header "From: a\r\nnocolon inthisline\r\n\r\n") + =error> "ill-formed header" + (validate-header #"From: a\r\nnocolon inthisline\r\n\r\n") + =error> "ill-formed header" + (validate-header "From: a\r\nMissingReturn: och\n\r\n") + =error> "missing ending CRLF" + (validate-header #"From: a\r\nMissingReturn: och\n\r\n") + =error> "missing ending CRLF" + (validate-header "From: a\r\nSpacein Fieldname: och\r\n\r\n") + =error> "ill-formed header" + (validate-header #"From: a\r\nSpacein Fieldname: och\r\n\r\n") + =error> "ill-formed header" + + (extract-field "From" test-header) + => "abc" + (extract-field #"From" test-header/bytes) + => #"abc" + (extract-field "To" test-header) + => "field is\r\n continued" + (extract-field #"To" test-header/bytes) + => #"field is\r\n continued" + (extract-field "Another" test-header) + => "zoo\r\n continued" + (extract-field #"Another" test-header/bytes) + => #"zoo\r\n continued" + + (replace-field "From" "def" test-header) + => "From: def\r\nTo: field is\r\n continued\r\nAnother: zoo\r\n continued\r\n\r\n" + (replace-field #"From" #"def" test-header/bytes) + => #"From: def\r\nTo: field is\r\n continued\r\nAnother: zoo\r\n continued\r\n\r\n" + (replace-field "From" #f test-header) + => "To: field is\r\n continued\r\nAnother: zoo\r\n continued\r\n\r\n" + (replace-field #"From" #f test-header/bytes) + => #"To: field is\r\n continued\r\nAnother: zoo\r\n continued\r\n\r\n" + + (replace-field "To" "qrs" test-header) + => "From: abc\r\nTo: qrs\r\nAnother: zoo\r\n continued\r\n\r\n" + (replace-field #"To" #"qrs" test-header/bytes) + => #"From: abc\r\nTo: qrs\r\nAnother: zoo\r\n continued\r\n\r\n" + (replace-field "To" #f test-header) + => "From: abc\r\nAnother: zoo\r\n continued\r\n\r\n" + (replace-field #"To" #f test-header/bytes) + => #"From: abc\r\nAnother: zoo\r\n continued\r\n\r\n" + + (replace-field "Another" "abc\r\n def" test-header) + => "From: abc\r\nTo: field is\r\n continued\r\nAnother: abc\r\n def\r\n\r\n" + (replace-field #"Another" #"abc\r\n def" test-header/bytes) + => #"From: abc\r\nTo: field is\r\n continued\r\nAnother: abc\r\n def\r\n\r\n" + (replace-field "Another" #f test-header) + => "From: abc\r\nTo: field is\r\n continued\r\n\r\n" + (replace-field #"Another" #f test-header/bytes) + => #"From: abc\r\nTo: field is\r\n continued\r\n\r\n" + + (remove-field "To" test-header) + => "From: abc\r\nAnother: zoo\r\n continued\r\n\r\n" + (remove-field #"To" test-header/bytes) + => #"From: abc\r\nAnother: zoo\r\n continued\r\n\r\n" + + (extract-all-fields test-header) + => `(("From" . "abc") ("To" . "field is\r\n continued") ("Another" . "zoo\r\n continued")) + (extract-all-fields test-header/bytes) + => `((#"From" . #"abc") (#"To" . #"field is\r\n continued") (#"Another" . #"zoo\r\n continued")) + + (append-headers test-header "Athird: data\r\n\r\n") + => "From: abc\r\nTo: field is\r\n continued\r\nAnother: zoo\r\n continued\r\nAthird: data\r\n\r\n" + (append-headers test-header/bytes #"Athird: data\r\n\r\n") + => #"From: abc\r\nTo: field is\r\n continued\r\nAnother: zoo\r\n continued\r\nAthird: data\r\n\r\n" + + )) diff --git a/collects/tests/net/main.ss b/collects/tests/net/main.ss new file mode 100644 index 0000000000..a9db1e8a23 --- /dev/null +++ b/collects/tests/net/main.ss @@ -0,0 +1,19 @@ +#lang scheme/base + +(require tests/eli-tester + (prefix-in ucodec: "uri-codec.ss") + (prefix-in url: "url.ss") + (prefix-in cgi: "cgi.ss") + (prefix-in head: "head.ss") + (prefix-in cookie: "cookie.ss") + (prefix-in encoders: "encoders.ss")) + +(define (tests) + (test do (begin (url:tests) + (ucodec:tests) + (cgi:tests) + (head:tests) + (cookie:tests) + (encoders:tests)))) + +(tests) diff --git a/collects/tests/net/uri-codec.ss b/collects/tests/net/uri-codec.ss new file mode 100644 index 0000000000..d53caa3ba5 --- /dev/null +++ b/collects/tests/net/uri-codec.ss @@ -0,0 +1,131 @@ +#lang scheme +(require net/uri-codec tests/eli-tester) + +(provide tests) +(define (tests) + (define sepmode current-alist-separator-mode) + (test (uri-decode "%Pq") => "%Pq" + (uri-decode "%P") => "%P" + + (alist->form-urlencoded '([a . "hel+lo \u7238"])) + => "a=hel%2Blo+%E7%88%B8" + (form-urlencoded->alist + (alist->form-urlencoded '([a . "hel+lo \u7238"]))) + => '([a . "hel+lo \u7238"]) + (alist->form-urlencoded '([a . "hel+lo"] [b . "good-bye"])) + => "a=hel%2Blo&b=good-bye" + + do (let ([alist '([a . "hel+lo"] [b . "good-bye"])] + [ampstr "a=hel%2Blo&b=good-bye"] + [semistr "a=hel%2Blo;b=good-bye"]) + (define (alist<->str mode str) + (parameterize ([sepmode (or mode (sepmode))]) + (test (alist->form-urlencoded alist) => str + (form-urlencoded->alist str) => alist))) + (alist<->str #f ampstr) ; test the default + (alist<->str 'amp ampstr) + (alist<->str 'amp-or-semi ampstr) + (alist<->str 'semi semistr) + (alist<->str 'semi-or-amp semistr)) + + (form-urlencoded->alist "x=foo&y=bar;z=baz") + => '([x . "foo"] [y . "bar"] [z . "baz"]) + (parameterize ([sepmode 'semi]) + (form-urlencoded->alist + (parameterize ([sepmode 'amp]) + (alist->form-urlencoded '([a . "hel+lo"] [b . "good-bye"]))))) + => '([a . "hel+lo&b=good-bye"]) + (parameterize ([sepmode 'amp]) + (form-urlencoded->alist + (parameterize ([sepmode 'semi]) + (alist->form-urlencoded '([a . "hel+lo"] [b . "good-bye"]))))) + => '([a . "hel+lo;b=good-bye"]) + + (alist->form-urlencoded '([aNt . "Hi"])) + => "aNt=Hi" + (form-urlencoded->alist (alist->form-urlencoded '([aNt . "Hi"]))) + => '([aNt . "Hi"]) + (alist->form-urlencoded (form-urlencoded->alist "aNt=Hi")) + => "aNt=Hi" + + (current-alist-separator-mode) => 'amp-or-semi + (current-alist-separator-mode 'bad) =error> "expected argument of type" + + ;; Test all ASCII chars + do + (let ([p (for/list ([n (in-range 128)]) + (let ([s (string (char-downcase (integer->char n)))]) + (cons (string->symbol s) s)))]) + (test (form-urlencoded->alist (alist->form-urlencoded p)) => p) + (let ([l (apply string-append (map cdr p))]) + (test (uri-decode (uri-encode l)) => l))) + + do (noels-tests) + + (uri-userinfo-encode "hello") => "hello" + (uri-userinfo-encode "hello there") => "hello%20there" + (uri-userinfo-encode "hello:there") => "hello:there" + (uri-userinfo-decode "hello") => "hello" + (uri-userinfo-decode "hello%20there") => "hello there" + (uri-userinfo-decode "hello:there") => "hello:there" + + )) + +;; tests adapted from Noel Welsh's original test suite +(define (noels-tests) + (define (pad2 str) + (if (= (string-length str) 1) (string-append "0" str) str)) + (define (%hex n) + (string-append "%" (pad2 (string-downcase (number->string n 16))))) + (define (%HEX n) + (string-append "%" (pad2 (string-upcase (number->string n 16))))) + (test + + (uri-encode "hello") => "hello" + (uri-encode "hello there") => "hello%20there" + + do + (for ([code (in-range 128)]) + (if (or (member code '(33 39 40 41 42 45 46 95 126)) + (<= 48 code 57) ; 0-9 + (<= 65 code 90) ; A-Z + (<= 97 code 122)) ; a-z + (test (uri-encode (string (integer->char code))) + => (string (integer->char code))) + (test (uri-encode (string (integer->char code))) + => (%HEX code)))) + + (alist->form-urlencoded '()) => "" + (alist->form-urlencoded '([key . "hello there"])) + => "key=hello+there" + (alist->form-urlencoded '([key1 . "hi"] [key2 . "hello"])) + => "key1=hi&key2=hello" + (alist->form-urlencoded '([key1 . "hello there"])) + => "key1=hello+there" + (uri-decode "hello") + => "hello" + (uri-decode "hello%20there") + => "hello there" + + ;; these were going from 0 to 255 in Noel's original test suite. + ;; Those fail here, however. + do (for ([code (in-range 128)]) + (test (uri-decode (%HEX code)) => (string (integer->char code)) + (uri-decode (%hex code)) => (string (integer->char code)) + (uri-decode (string (integer->char code))) + => (string (integer->char code)))) + + ;; form-urlencoded->alist + (form-urlencoded->alist "") => '() + (form-urlencoded->alist "key=value") + => '([key . "value"]) + (form-urlencoded->alist "key=hello+there") + => '([key . "hello there"]) + (form-urlencoded->alist "key=a%20value") + => '([key . "a value"]) + (form-urlencoded->alist "key") + => '([key . #f]) + (form-urlencoded->alist "key1=value+1&key2=value+2") + => '([key1 . "value 1"] [key2 . "value 2"]) + + )) diff --git a/collects/tests/net/url.ss b/collects/tests/net/url.ss new file mode 100644 index 0000000000..e6b52ef462 --- /dev/null +++ b/collects/tests/net/url.ss @@ -0,0 +1,357 @@ +#lang scheme +(require net/url tests/eli-tester + (only-in net/uri-codec current-alist-separator-mode)) + +(define (url->vec url) + (vector + (url-scheme url) + (url-user url) + (url-host url) + (url-port url) + (url-path-absolute? url) + (map (lambda (x) + (list->vector (cons (path/param-path x) (path/param-param x)))) + (url-path url)) + (url-query url) + (url-fragment url))) + +(define (vec->url vec) + (make-url + (vector-ref vec 0) + (vector-ref vec 1) + (vector-ref vec 2) + (vector-ref vec 3) + (vector-ref vec 4) + (map (lambda (x) + (let ([lst (vector->list x)]) + (make-path/param (car lst) (cdr lst)))) + (vector-ref vec 5)) + (vector-ref vec 6) + (vector-ref vec 7))) + +(define (string->url/vec str) (url->vec (string->url str))) +(define (url/vec->string vec) (url->string (vec->url vec))) + +(define (test-s->u vec str) + (test (string->url/vec str) => vec + (url/vec->string vec) => str)) + +(define (test-c-u/r expected base relative) + (define (combine-url/relative-vec x y) + (url->vec (combine-url/relative (vec->url x) y))) + (define (->vec x) (url->vec (if (string? x) (string->url x) x))) + (test (combine-url/relative-vec (->vec base) relative) + => (->vec expected))) + +(define (run-tests) + (test + ;; Test the current-proxy-servers parameter can be set + (parameterize ([current-proxy-servers '(("http" "proxy.com" 3128))]) + (current-proxy-servers)) + => '(("http" "proxy.com" 3128))) + + (test-s->u #(#f #f #f #f #t (#("")) () #f) + "/") + (test-s->u #(#f #f #f #f #f () () #f) + "") + + (test-s->u #("http" #f #f #f #t (#("")) () #f) + "http:/") + + (test-s->u #("http" #f "" #f #t (#("")) () #f) + "http:///") + + (test-s->u #("http" #f "www.drscheme.org" #f #f () () #f) + "http://www.drscheme.org") + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("")) () #f) + "http://www.drscheme.org/") + + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) () #f) + "http://www.drscheme.org/a/b/c") + (test-s->u #("http" "robby" "www.drscheme.org" #f #t (#("a") #("b") #("c")) () #f) + "http://robby@www.drscheme.org/a/b/c") + (test-s->u #("http" #f "www.drscheme.org" 8080 #t (#("a") #("b") #("c")) () #f) + "http://www.drscheme.org:8080/a/b/c") + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) () "joe") + "http://www.drscheme.org/a/b/c#joe") + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tim . "")) #f) + "http://www.drscheme.org/a/b/c?tim=") + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tim . "")) "joe") + "http://www.drscheme.org/a/b/c?tim=#joe") + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tim . "tim")) "joe") + "http://www.drscheme.org/a/b/c?tim=tim#joe") + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tam . "tom")) "joe") + "http://www.drscheme.org/a/b/c?tam=tom#joe") + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tam . "tom") (pam . "pom")) "joe") + "http://www.drscheme.org/a/b/c?tam=tom&pam=pom#joe") + (parameterize ([current-alist-separator-mode 'semi]) + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tam . "tom") (pam . "pom")) "joe") + "http://www.drscheme.org/a/b/c?tam=tom;pam=pom#joe")) + (parameterize ([current-alist-separator-mode 'amp]) + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tam . "tom") (pam . "pom")) "joe") + "http://www.drscheme.org/a/b/c?tam=tom&pam=pom#joe")) + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c" "b")) () #f) + "http://www.drscheme.org/a/b/c;b") + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a" "x") #("b") #("c" "b")) () #f) + "http://www.drscheme.org/a;x/b/c;b") + + ;; test unquoting for % + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((ti#m . "")) "jo e") + "http://www.drscheme.org/a/b/c?ti%23m=#jo%20e") + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a " " a") #(" b ") #(" c ")) () #f) + "http://www.drscheme.org/a%20;%20a/%20b%20/%20c%20") + (test-s->u #("http" "robb y" "www.drscheme.org" #f #t (#("")) () #f) + "http://robb%20y@www.drscheme.org/") + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("%a") #("b/") #("c")) () #f) + "http://www.drscheme.org/%25a/b%2F/c") + (test-s->u #("http" "robby:password" "www.drscheme.org" #f #t (#("")) () #f) + "http://robby:password@www.drscheme.org/") + (test "robby:password" (lambda (x) (url-user (string->url x))) "http://robby%3apassword@www.drscheme.org/") + + ;; test the characters that need to be encoded in paths vs those that do not need to + ;; be encoded in paths + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a:@!$&'()*+,=z") #("/?#[];") #("")) () #f) + "http://www.drscheme.org/a:@!$&'()*+,=z/%2F%3F%23%5B%5D%3B/") + + (test-s->u #("http" #f "www.drscheme.org" #f #t (#(".") #("..") #(same) #(up) #("...") #("abc.def")) () #f) + "http://www.drscheme.org/%2e/%2e%2e/./../.../abc.def") + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("." "") #(".." "") #(same "") #(up "") #("..." "") #("abc.def" "")) () #f) + "http://www.drscheme.org/%2e;/%2e%2e;/.;/..;/...;/abc.def;") + + ;; test other scheme identifiers + (test-s->u #("blah" #f "www.foo.com" #f #t (#("")) () #f) + "blah://www.foo.com/") + (test-s->u #("blah99" #f "www.foo.com" #f #t (#("")) () #f) + "blah99://www.foo.com/") + (test-s->u #("blah+" #f "www.foo.com" #f #t (#("")) () #f) + "blah+://www.foo.com/") + (test-s->u #("a+b-c456.d" #f "www.foo.com" #f #t (#("")) () #f) + "a+b-c456.d://www.foo.com/") + + ;; a colon and other junk (`sub-delims') can appear in usernames + (test #("http" "x:!$&'()*+,;=y" "www.drscheme.org" #f #t (#("a")) () #f) + string->url/vec + "http://x:!$&'()*+,;=y@www.drscheme.org/a") + ;; a colon and atsign can appear in absolute paths + (test-s->u #(#f #f #f #f #t (#("x:@y") #("z")) () #f) + "/x:@y/z") + ;; and in relative paths as long as it's not in the first element + (test-s->u #(#f #f #f #f #f (#("x") #("y:@z")) () #f) + "x/y:@z") + + ;; test bad schemes + (test + (string->url "://www.foo.com/") =error> url-exception? + (string->url "9://www.foo.com/") =error> url-exception? + (string->url "9a://www.foo.com/") =error> url-exception? + (string->url "a*b://www.foo.com/") =error> url-exception? + (string->url "a b://www.foo.com/") =error> url-exception?) + + ;; test file: urls + (test-s->u #("file" #f "" #f #t (#("abc") #("def.html")) () #f) + "file:///abc/def.html") + (test (url->string (string->url "file:///abc/def.html")) + => "file:///abc/def.html") + (parameterize ([file-url-path-convention-type 'unix]) + (test (url->string (string->url "file://a/b")) + => "file://a/b") + (test-s->u #("file" #f "localhost" #f #t (#("abc") #("def.html")) () #f) + "file://localhost/abc/def.html")) + + ;; test files: urls with colons, and the different parsing on Windows + (test-s->u #("file" #f "localhost" 123 #t (#("abc") #("def.html")) () #f) + "file://localhost:123/abc/def.html") + (parameterize ([file-url-path-convention-type 'unix]) + ;; different parse for file://foo:/... + (test (string->url/vec "file://foo:/abc/def.html") + => #("file" #f "foo" #f #t (#("abc") #("def.html")) () #f))) + (parameterize ([file-url-path-convention-type 'windows]) + (test (string->url/vec "file://foo:/abc/def.html") + => #("file" #f "" #f #t (#("foo:") #("abc") #("def.html")) () #f) + (string->url/vec "file://c:/abc/def.html") + => #("file" #f "" #f #t (#("c:") #("abc") #("def.html")) () #f) + (string->url/vec "file:\\\\d\\c\\abc\\def.html") + => #("file" #f "" #f #t (#("") #("d") #("c") #("abc") #("def.html")) () #f))) + + (parameterize ([file-url-path-convention-type 'unix]) + ;; but no effect on http://foo:/... + (test (string->url/vec "http://foo:/abc/def.html") + => #("http" #f "foo" #f #t (#("abc") #("def.html")) () #f))) + (parameterize ([file-url-path-convention-type 'windows]) + (test (string->url/vec "http://foo:/abc/def.html") + => #("http" #f "foo" #f #t (#("abc") #("def.html")) () #f))) + + (test (url->string (path->url (bytes->path #"c:\\a\\b" 'windows))) + => "file:///c:/a/b" + (url->string (path->url (bytes->path #"\\\\?\\c:\\a\\b" 'windows))) + => "file:///c:/a/b") + + (test + (path->bytes (url->path (path->url (bytes->path #"/a/b/c" 'unix)) 'unix)) + => #"/a/b/c" + (path->bytes (url->path (path->url (bytes->path #"a/b/c" 'unix)) 'unix)) + => #"a/b/c" + (path->bytes (url->path (path->url (bytes->path #"c:/a/b" 'windows)) 'windows)) + => #"c:\\a\\b" + (path->bytes (url->path (path->url (bytes->path #"a/b" 'windows)) 'windows)) + => #"a\\b" + (path->bytes (url->path (path->url (bytes->path #"//d/c/a" 'windows)) 'windows)) + => #"\\\\d\\c\\a" + (path->bytes (url->path (path->url (bytes->path #"\\\\?\\c:\\a\\b" 'windows)) 'windows)) + => #"c:\\a\\b" + (path->bytes (url->path (path->url (bytes->path #"\\\\?\\UNC\\d\\c\\a\\b" 'windows)) 'windows)) + => #"\\\\d\\c\\a\\b" + (path->bytes (url->path (path->url (bytes->path #"\\\\?\\c:\\a/x\\b" 'windows)) 'windows)) + => #"\\\\?\\c:\\a/x\\b" + (path->bytes (url->path (path->url (bytes->path #"\\\\?\\UNC\\d\\\\c\\a/x\\b" 'windows)) 'windows)) + => #"\\\\?\\UNC\\d\\c\\a/x\\b") + + ;; see PR8809 (value-less keys in the query part) + (test-s->u #("http" #f "foo.bar" #f #t (#("baz")) ((ugh . #f)) #f) + "http://foo.bar/baz?ugh") + (test-s->u #("http" #f "foo.bar" #f #t (#("baz")) ((ugh . "")) #f) + "http://foo.bar/baz?ugh=") + (test-s->u #("http" #f "foo.bar" #f #t (#("baz")) ((ugh . #f) (x . "y") (|1| . "2")) #f) + "http://foo.bar/baz?ugh&x=y&1=2") + (test-s->u #("http" #f "foo.bar" #f #t (#("baz")) ((ugh . "") (x . "y") (|1| . "2")) #f) + "http://foo.bar/baz?ugh=&x=y&1=2") + + (parameterize ([current-alist-separator-mode 'amp]) + (test-s->u #("http" #f "foo.bar" #f #t (#("baz")) ((ugh . #f) (x . "y") (|1| . "2")) #f) + "http://foo.bar/baz?ugh&x=y&1=2")) + (parameterize ([current-alist-separator-mode 'semi]) + (test-s->u #("http" #f "foo.bar" #f #t (#("baz")) ((ugh . #f) (x . "y") (|1| . "2")) #f) + "http://foo.bar/baz?ugh;x=y;1=2")) + + ;; test case sensitivity + (test (string->url/vec + "HTTP://ROBBY@WWW.DRSCHEME.ORG:80/INDEX.HTML;XXX?T=P#YYY") + => #("http" "ROBBY" "www.drscheme.org" 80 #t (#("INDEX.HTML" "XXX")) ((T . "P")) "YYY")) + + (test-s->u #("mailto" #f #f #f #f (#("robby@plt-scheme.org")) () #f) + "mailto:robby@plt-scheme.org") + + (test (string->url/vec "http://www.drscheme.org?bar=馨慧") + #("http" #f "www.drscheme.org" #f #f () ((bar . "馨慧")) #f)) + + (test (string->url/vec "http://www.drscheme.org?bár=é") + => #("http" #f "www.drscheme.org" #f #f () ((bár . "é")) #f)) + + (test-c-u/r "http://www.drscheme.org" + (make-url #f #f #f #f #f '() '() #f) + "http://www.drscheme.org") + + (test-c-u/r "http://www.drscheme.org" + "http://www.drscheme.org" + "") + + (test-c-u/r "http://www.mzscheme.org" + "http://www.drscheme.org/" + "http://www.mzscheme.org") + + (test-c-u/r "http://www.drscheme.org/index.html" + "http://www.drscheme.org/" + "index.html") + (test-c-u/r "http://www.drscheme.org/index.html" + "http://www.drscheme.org/" + "/index.html") + (test-c-u/r "http://www.drscheme.org/index.html" + "http://www.drscheme.org/a/b/c/" + "/index.html") + (test-c-u/r "http://www.drscheme.org/a/b/index.html" + "http://www.drscheme.org/a/b/c" + "index.html") + (test-c-u/r "http://www.drscheme.org/a/b/c/index.html" + "http://www.drscheme.org/a/b/c/" + "index.html") + (test-c-u/r "http://www.drscheme.org/a/b/d/index.html" + "http://www.drscheme.org/a/b/c" + "d/index.html") + (test-c-u/r "http://www.drscheme.org/a/b/c/d/index.html" + "http://www.drscheme.org/a/b/c/" + "d/index.html") + (test-c-u/r "http://www.drscheme.org/a/b/index.html" + "http://www.drscheme.org/a/b/c/" + "../index.html") + (test-c-u/r "http://www.drscheme.org/a/b/c/index.html" + "http://www.drscheme.org/a/b/c/" + "./index.html") + (test-c-u/r "http://www.drscheme.org/a/b/c/%2e%2e/index.html" + "http://www.drscheme.org/a/b/c/" + "%2e%2e/index.html") + (test-c-u/r "http://www.drscheme.org/a/index.html" + "http://www.drscheme.org/a/b/../c/" + "../index.html") + + (test-c-u/r "http://www.drscheme.org/a/b/c/d/index.html" + "http://www.drscheme.org/a/b/c/d/index.html#ghijkl" + "index.html") + (test-c-u/r "http://www.drscheme.org/a/b/c/d/index.html#abcdef" + "http://www.drscheme.org/a/b/c/d/index.html#ghijkl" + "#abcdef") + + (test-c-u/r "file:///a/b/c/d/index.html" + "file:///a/b/c/" + "d/index.html") + (test-c-u/r "file:///a/b/d/index.html" + "file:///a/b/c" + "d/index.html") + + ;; tests from rfc 3986 + (for-each + (λ (line) (test-c-u/r (caddr line) "http://a/b/c/d;p?q" (car line))) + '(("g:h" = "g:h") + ("g" = "http://a/b/c/g") + ("./g" = "http://a/b/c/g") + ("g/" = "http://a/b/c/g/") + ("/g" = "http://a/g") + ("//g" = "http://g") + ("?y" = "http://a/b/c/d;p?y") + ("g?y" = "http://a/b/c/g?y") + ("#s" = "http://a/b/c/d;p?q#s") + ("g#s" = "http://a/b/c/g#s") + ("g?y#s" = "http://a/b/c/g?y#s") + (";x" = "http://a/b/c/;x") + ("g;x" = "http://a/b/c/g;x") + ("g;x?y#s" = "http://a/b/c/g;x?y#s") + ("" = "http://a/b/c/d;p?q") + ("." = "http://a/b/c/") + ("./" = "http://a/b/c/") + (".." = "http://a/b/") + ("../" = "http://a/b/") + ("../g" = "http://a/b/g") + ("../.." = "http://a/") + ("../../" = "http://a/") + ("../../g" = "http://a/g") + + ;; abnormal examples follow + + ("../../../g" = "http://a/g") + ("../../../../g" = "http://a/g") + + ("/./g" = "http://a/g") + ("/../g" = "http://a/g") + ("g." = "http://a/b/c/g.") + (".g" = "http://a/b/c/.g") + ("g.." = "http://a/b/c/g..") + ("..g" = "http://a/b/c/..g") + + ("./../g" = "http://a/b/g") + ("./g/." = "http://a/b/c/g/") + ("g/./h" = "http://a/b/c/g/h") + ("g/../h" = "http://a/b/c/h") + ("g;x=1/./y" = "http://a/b/c/g;x=1/y") + ("g;x=1/../y" = "http://a/b/c/y") + + ("g?y/./x" = "http://a/b/c/g?y/./x") + ("g?y/../x" = "http://a/b/c/g?y/../x") + ("g#s/./x" = "http://a/b/c/g#s/./x") + ("g#s/../x" = "http://a/b/c/g#s/../x") + ("http:g" = "http:g") ; for strict parsers + + )) + + ) + +(provide tests) +(define (tests) (test do (run-tests))) diff --git a/collects/tests/run-automated-tests.ss b/collects/tests/run-automated-tests.ss index b0978b659b..03105e78b9 100755 --- a/collects/tests/run-automated-tests.ss +++ b/collects/tests/run-automated-tests.ss @@ -38,6 +38,8 @@ ;; [require "stepper/automatic-tests.ss" (lib "scheme/base")] [require "lazy/main.ss"] [require "scribble/main.ss"] + [require "net/main.ss"] + [require "file/main.ss"] )) diff --git a/collects/tests/scribble/main.ss b/collects/tests/scribble/main.ss index b95d0d3dc7..8ef6019dc3 100644 --- a/collects/tests/scribble/main.ss +++ b/collects/tests/scribble/main.ss @@ -1,94 +1,149 @@ #lang scheme/base -(require tests/eli-tester scribble/text/syntax-utils scheme/runtime-path) +(require tests/eli-tester scribble/text/syntax-utils + scheme/runtime-path scheme/port scheme/sandbox + (prefix-in doc: (lib "scribblings/scribble/preprocessor.scrbl"))) (define-runtime-path text-dir "text") +(define-runtime-path this-dir ".") -(test +(define (tests) + (begin/collect-tests) + (preprocessor-tests)) - ;; begin/collect scope etc - (begin/collect 1) => 1 - (begin/collect 1 2 3) => '(1 2 3) - (begin/collect) => '() - (begin/collect (define x 1) x) => 1 - (begin/collect (define x 1)) => '() - (begin/collect (define x 1) x x x) => '(1 1 1) - (begin/collect (define x 1) (define y 2) x y x y) => '(1 2 1 2) - (begin/collect (define x 1) x (define y 2) y) => '(1 2) - (begin/collect (define x 1) x (define y 2)) => '(1) - (begin/collect (define x 1) x x (define y 2) y y) => '(1 1 2 2) - (begin/collect (define x 1) x (define x 2) x) => '(1 2) - (begin/collect (define x 1) x x (define x 2) x x) => '(1 1 2 2) - (begin/collect (define (x) y) (define y 1) (x) (x) (x)) => '(1 1 1) - (begin/collect (define x 1) x (define y 2) x) => '(1 1) - (begin/collect (define x 1) x x (define y 2) x x) => '(1 1 1 1) - (begin/collect (define x 1) x x (define y x) y y) => '(1 1 1 1) - (begin/collect (define (x) y) (define y 1) (x) (x) - (define (x) y) (define y 2) (x) (x)) - => '(1 1 2 2) - (begin/collect (define-syntax-rule (DEF x y) (define x y)) (DEF x 1) x x) - => '(1 1) - (begin/collect (define-syntax-rule (DEF x y) (define x y)) 1 (DEF x 2) x) - => '(1 2) - (begin/collect (define-syntax-rule (DEF x y) (define x y)) - (DEF x 1) x x - (DEF x 2) x x) - => '(1 1 2 2) - (begin/collect (define (x) y) - (define-syntax-rule (DEF x y) (define x y)) - (DEF y 1) (x) (x) - (DEF y 2) (x) (x)) - => '(1 1 1 1) - (let ([y 1]) (begin/collect y y (define x y) x y x)) => '(1 1 1 1 1) - (let ([y 1]) (begin/collect y y (define y 2) y y)) => '(1 1 2 2) - (let ([y 1]) (begin/collect (define (x) y) (x) (x))) => '(1 1) - (let ([y 1]) (begin/collect (define (x) y) (define y 2) (x) (x))) => '(2 2) - (let ([y 1]) (begin/collect (define (x) y) (x) (x) (define y 2) y y)) - => '(1 1 2 2) - (let ([y 1]) (begin/collect (define (x) y) (x) (x) (define y 2) y y (x))) - => '(1 1 2 2 1) - (let ([y 1]) (begin/collect (define (x) y) (x) (x) (define y 2) (x) y y)) - => '(1 1 1 2 2) - (begin/collect (begin (define (x) y) - (define-syntax-rule (DEF x y) (define x y)) - (define y 2)) - (x) (x)) - => '(2 2) - (begin/collect (define (x) y) - (begin (define-syntax-rule (DEF x y) (define x y)) - (define y 2)) - (x) (x)) - => '(2 2) - (begin/collect (define (x) y) - (define-syntax-rule (DEF x y) (define x y)) - (begin (define y 2)) - (x) (x)) - => '(2 2) - (begin/collect (begin (begin (begin (define (x) y)) - (begin (define-syntax-rule (DEF x y) - (define x y)))) - (begin (begin (define y 2)) - (begin (x))) - (begin (x)))) - => '(2 2) - (begin/collect 1 - (define (f x #:< [< "<"] #:> [> ">"]) (list < x >)) - (f 1) - (f #:< "[" 2) - (f 3 #:> "]" #:< "[")) - => '(1 ("<" 1 ">") ("[" 2 ">") ("[" 3 "]")) +(define (begin/collect-tests) + (test - ;; preprocessor functionality - (parameterize ([current-directory text-dir]) - (for ([ifile (map path->string (directory-list))] - #:when (and (file-exists? ifile) - (regexp-match? #rx"^i[0-9]+\\.ss$" ifile))) - (define ofile (regexp-replace #rx"^i([0-9]+)\\..*$" ifile "o\\1.txt")) - (define expected (call-with-input-file ofile - (lambda (i) (read-bytes (file-size ofile) i)))) - (define o (open-output-bytes)) - (parameterize ([current-output-port o]) - (dynamic-require (path->complete-path ifile) #f)) - (test (get-output-bytes o) => expected))) + ;; begin/collect scope etc + (begin/collect 1) => 1 + (begin/collect 1 2 3) => '(1 2 3) + (begin/collect) => '() + (begin/collect (define x 1) x) => 1 + (begin/collect (define x 1)) => '() + (begin/collect (define x 1) x x x) => '(1 1 1) + (begin/collect (define x 1) (define y 2) x y x y) => '(1 2 1 2) + (begin/collect (define x 1) x (define y 2) y) => '(1 2) + (begin/collect (define x 1) x (define y 2)) => '(1) + (begin/collect (define x 1) x x (define y 2) y y) => '(1 1 2 2) + (begin/collect (define x 1) x (define x 2) x) => '(1 2) + (begin/collect (define x 1) x x (define x 2) x x) => '(1 1 2 2) + (begin/collect (define (x) y) (define y 1) (x) (x) (x)) => '(1 1 1) + (begin/collect (define x 1) x (define y 2) x) => '(1 1) + (begin/collect (define x 1) x x (define y 2) x x) => '(1 1 1 1) + (begin/collect (define x 1) x x (define y x) y y) => '(1 1 1 1) + (begin/collect (define (x) y) (define y 1) (x) (x) + (define (x) y) (define y 2) (x) (x)) + => '(1 1 2 2) + (begin/collect (define-syntax-rule (DEF x y) (define x y)) (DEF x 1) x x) + => '(1 1) + (begin/collect (define-syntax-rule (DEF x y) (define x y)) 1 (DEF x 2) x) + => '(1 2) + (begin/collect (define-syntax-rule (DEF x y) (define x y)) + (DEF x 1) x x + (DEF x 2) x x) + => '(1 1 2 2) + (begin/collect (define (x) y) + (define-syntax-rule (DEF x y) (define x y)) + (DEF y 1) (x) (x) + (DEF y 2) (x) (x)) + => '(1 1 1 1) + (let ([y 1]) (begin/collect y y (define x y) x y x)) => '(1 1 1 1 1) + (let ([y 1]) (begin/collect y y (define y 2) y y)) => '(1 1 2 2) + (let ([y 1]) (begin/collect (define (x) y) (x) (x))) => '(1 1) + (let ([y 1]) (begin/collect (define (x) y) (define y 2) (x) (x))) => '(2 2) + (let ([y 1]) (begin/collect (define (x) y) (x) (x) (define y 2) y y)) + => '(1 1 2 2) + (let ([y 1]) (begin/collect (define (x) y) (x) (x) (define y 2) y y (x))) + => '(1 1 2 2 1) + (let ([y 1]) (begin/collect (define (x) y) (x) (x) (define y 2) (x) y y)) + => '(1 1 1 2 2) + (begin/collect (begin (define (x) y) + (define-syntax-rule (DEF x y) (define x y)) + (define y 2)) + (x) (x)) + => '(2 2) + (begin/collect (define (x) y) + (begin (define-syntax-rule (DEF x y) (define x y)) + (define y 2)) + (x) (x)) + => '(2 2) + (begin/collect (define (x) y) + (define-syntax-rule (DEF x y) (define x y)) + (begin (define y 2)) + (x) (x)) + => '(2 2) + (begin/collect (begin (begin (begin (define (x) y)) + (begin (define-syntax-rule (DEF x y) + (define x y)))) + (begin (begin (define y 2)) + (begin (x))) + (begin (x)))) + => '(2 2) + (begin/collect 1 + (define (f x #:< [< "<"] #:> [> ">"]) (list < x >)) + (f 1) + (f #:< "[" 2) + (f 3 #:> "]" #:< "[")) + => '(1 ("<" 1 ">") ("[" 2 ">") ("[" 3 "]")) - ) + )) + +(define (preprocessor-tests) + ;; (sample-file-tests) + (in-documentation-tests)) + +(define (sample-file-tests) + (parameterize ([current-directory text-dir]) + (for ([ifile (map path->string (directory-list))] + #:when (and (file-exists? ifile) + (regexp-match? #rx"^i[0-9]+\\.ss$" ifile))) + (define ofile (regexp-replace #rx"^i([0-9]+)\\..*$" ifile "o\\1.txt")) + (define expected (call-with-input-file ofile + (lambda (i) (read-bytes (file-size ofile) i)))) + (define o (open-output-bytes)) + (parameterize ([current-output-port o]) + (dynamic-require (path->complete-path ifile) #f)) + (test (get-output-bytes o) => expected)))) + +(define (in-documentation-tests) + (define (text-test line in-text out-text more) + (define-values (i o) (make-pipe 512)) + (define-values (expected len-to-read) + (let ([m (regexp-match-positions #rx"\n\\.\\.\\.$" out-text)]) + (if m + (values (substring out-text 0 (caar m)) (caar m)) + (values out-text #f)))) + ;; test with name indicating the source + (define-syntax-rule (t . stuff) + (test ;#:failure-message + ;(format "preprocessor test failure at line ~s" line) + . stuff)) + (parameterize ([current-directory this-dir] + [sandbox-output o] + [sandbox-error-output current-output-port]) + (define exn #f) + (define thd #f) + (define (run) + ;; only need to evaluate the module, so we have its output; but do that + ;; in a thread, since we might want to look at just a prefix of an + ;; infinite output + (with-handlers ([void (lambda (e) (set! exn e))]) + (make-module-evaluator in-text) + (close-output-port o))) + (for ([m more]) + (call-with-output-file (car m) #:exists 'truncate + (lambda (o) (display (cdr m) o)))) + (set! thd (thread run)) + (t (with-limits 2 #f + (if len-to-read (read-string len-to-read i) (port->string i))) + => expected) + (t (begin (kill-thread thd) (cond [exn => raise] [else #t]))) + (for ([m more]) + (when (file-exists? (car m)) (delete-file (car m)))))) + (call-with-trusted-sandbox-configuration + (lambda () + (for ([t (in-list (doc:tests))]) + (begin (apply text-test t)))))) + +;; run all +(test do (tests)) diff --git a/collects/tests/scribble/text/i01.ss b/collects/tests/scribble/text/i01.ss deleted file mode 100644 index 3769a0749e..0000000000 --- a/collects/tests/scribble/text/i01.ss +++ /dev/null @@ -1,3 +0,0 @@ -#lang scribble/text - -foo diff --git a/collects/tests/scribble/text/i02.ss b/collects/tests/scribble/text/i02.ss deleted file mode 100644 index ad930c26c5..0000000000 --- a/collects/tests/scribble/text/i02.ss +++ /dev/null @@ -1,25 +0,0 @@ -#lang scribble/text - -@define[name]{PLT Scheme} - -Suggested price list for "@name" - -@; test mutual recursion, throwing away inter-definition spaces -@; <-- this is needed to get only one line of space above -@(define (items-num) - (length items)) - -@(define average - (delay (/ (apply + (map car items)) (length items)))) - -@(define items - (list @list[99]{Home} - @list[149]{Professional} - @list[349]{Enterprize})) - -@(for/list ([i items] [n (in-naturals)]) - @list{@|n|. @name @cadr[i] edition: $@car[i].99 - @||})@; <-- also needed - -Total: @items-num items -Average price: $@|average|.99 diff --git a/collects/tests/scribble/text/i03.ss b/collects/tests/scribble/text/i03.ss deleted file mode 100644 index 636fd376f1..0000000000 --- a/collects/tests/scribble/text/i03.ss +++ /dev/null @@ -1,18 +0,0 @@ -#lang scribble/text - ----***--- -@(define (angled . body) (list "<" body ">")) - @(define (shout . body) @angled[(map string-upcase body)]) - @define[z]{blah} - -blah @angled{blah @shout{@z} blah} blah - -@(define-syntax-rule @twice[x] - (list x ", " x)) - -@twice{@twice{blah}} - -@include{i3a} - -@(let ([name "Eli"]) (let ([foo (include "i3b")]) (list foo "\n" foo))) -Repeating yourself much? diff --git a/collects/tests/scribble/text/i03a b/collects/tests/scribble/text/i03a deleted file mode 100644 index e1009c1cda..0000000000 --- a/collects/tests/scribble/text/i03a +++ /dev/null @@ -1 +0,0 @@ -Warning: blah overdose might be fatal diff --git a/collects/tests/scribble/text/i03b b/collects/tests/scribble/text/i03b deleted file mode 100644 index 9037c24a65..0000000000 --- a/collects/tests/scribble/text/i03b +++ /dev/null @@ -1,12 +0,0 @@ -@(define (foo . xs) (bar xs)) -@(begin (define (isname) @list{is @foo{@name}}) - (define-syntax-rule (DEF x y) (define x y))) -@(DEF (bar x) (list z " " x)) -@(define-syntax-rule (BEG x ...) (begin x ...)) -@(BEG (define z "zee")) - -My name @isname -@DEF[x]{Foo!} - - ... and to that I say "@x", I think. - diff --git a/collects/tests/scribble/text/i04.ss b/collects/tests/scribble/text/i04.ss deleted file mode 100644 index 6482834867..0000000000 --- a/collects/tests/scribble/text/i04.ss +++ /dev/null @@ -1,24 +0,0 @@ -#!/bin/env mzscheme -#lang scribble/text - -@; demonstrates how indentation is preserved inside lists - -begin - a - b - @list{c - d - @list{e - f - g} - h - i - @list{j - k - l} - m - n - o} - p - q -end diff --git a/collects/tests/scribble/text/i05.ss b/collects/tests/scribble/text/i05.ss deleted file mode 100644 index f82514de3d..0000000000 --- a/collects/tests/scribble/text/i05.ss +++ /dev/null @@ -1,30 +0,0 @@ -#!/bin/env mzscheme -#lang scribble/text - -@(define (((if . c) . t) . e) - @list{ - if (@c) - @t - else - @e - fi}) - -@; indentation works even when coming from a function - -function foo() { - @list{if (1 < 2) - something1 - else - @@@if{2<3}{something2}{something3} - repeat 3 { - @@@if{2<3}{something2}{something3} - @@@if{2<3}{ - @list{something2.1 - something2.2} - }{ - something3 - } - } - fi} - return -} diff --git a/collects/tests/scribble/text/i06.ss b/collects/tests/scribble/text/i06.ss deleted file mode 100644 index e79db613e9..0000000000 --- a/collects/tests/scribble/text/i06.ss +++ /dev/null @@ -1,25 +0,0 @@ -#!/bin/env mzscheme -#lang scribble/text - -@; indentation works with a list, even a single string with a newline -@; in a list, but not in a string by itself - -function foo() { - prefix - @list{if (1 < 2) - something1 - else - @list{something2 - something3} - @'("something4\nsomething5") - @"something6\nsomething7" - fi} - return -} - -@; can be used with a `display', but makes sense only at the top level -@; or in thunks (not demonstrated here) -@; -@(display 123) foo @list{bar1 - bar2 - bar2} diff --git a/collects/tests/scribble/text/i07.ss b/collects/tests/scribble/text/i07.ss deleted file mode 100644 index 193c1ce637..0000000000 --- a/collects/tests/scribble/text/i07.ss +++ /dev/null @@ -1,18 +0,0 @@ -#!/bin/env mzscheme -#lang scribble/text - -@; demonstrates using a prefix - -function foo() { - var lst = [@list{item1, - item2}] - @prefix["//"]{ comment1 - comment2 - comment3 - @list{comment4 - comment5 - comment6} - @prefix["*"]{ more - stuff}} - return -} diff --git a/collects/tests/scribble/text/i08.ss b/collects/tests/scribble/text/i08.ss deleted file mode 100644 index 97227b7515..0000000000 --- a/collects/tests/scribble/text/i08.ss +++ /dev/null @@ -1,17 +0,0 @@ -#!/bin/env mzscheme -#lang scribble/text - -@; using verbatim -@(define (((foo . var) . expr1) . expr2) - @list{int var; - @verbatim{#ifdef FOO} - var = [@expr1, - @expr2]; - @verbatim{#else} - var = [@expr2, - @expr1]; - @verbatim{#endif}}) - -int blah() { - @@@foo{i}{something}{something_else} -} diff --git a/collects/tests/scribble/text/i09.ss b/collects/tests/scribble/text/i09.ss deleted file mode 100644 index 59973b2abf..0000000000 --- a/collects/tests/scribble/text/i09.ss +++ /dev/null @@ -1,25 +0,0 @@ -#!/bin/env mzscheme -#lang scribble/text - -@(begin - ;; This is a somewhat contrived example, showing how to use lists - ;; and verbatim to control the added prefix - (define (item . text) - ;; notes: the `flush' makes the prefix to that point print so the - ;; verbatim "* " is printed after it, which overwrites the "| " - ;; prefix - (cons flush (prefix "| " (cons (verbatim "* ") text)))) - ;; note that a simple item with spaces is much easier: - (define (simple . text) @list{* @text})) - -start - @item{blah blah blah - blah blah blah - @item{more stuff - more stuff - more stuff} - blah blah blah - blah blah blah} - @simple{more blah - blah blah} -end diff --git a/collects/tests/scribble/text/i10.ss b/collects/tests/scribble/text/i10.ss deleted file mode 100644 index 42592fd76e..0000000000 --- a/collects/tests/scribble/text/i10.ss +++ /dev/null @@ -1,33 +0,0 @@ -#!/bin/env mzscheme -#lang scribble/text - -@(define (((if . c) . t) . e) - @list{if (@c) - @t - else - @e - fi}) - -function foo() { - @prefix["//"]{ comment1 - comment2 @list{comment3 - comment4}} - var x = [@list{item1, - item2}] - bar1 - @list{if (1 < 2) - @list{something1 - something2 - something3} - else - @@@if{2 < 3}{something_else}{something_completely_different} - @@@if{3 < 4}{ - another_something_else1 - another_something_else2 - }{ - another_something_completely_different - } - fi - } - return; -} diff --git a/collects/tests/scribble/text/i11.ss b/collects/tests/scribble/text/i11.ss deleted file mode 100644 index 558c6a224e..0000000000 --- a/collects/tests/scribble/text/i11.ss +++ /dev/null @@ -1,13 +0,0 @@ -#!/bin/env mzscheme -#lang scribble/text - -@(define (block x) - @splice{{ - blah(@x); - }}) - -start - @splice{foo(); - loop:} - @list{if (something) @block{stuff}} -end diff --git a/collects/tests/scribble/text/o01.txt b/collects/tests/scribble/text/o01.txt deleted file mode 100644 index 257cc5642c..0000000000 --- a/collects/tests/scribble/text/o01.txt +++ /dev/null @@ -1 +0,0 @@ -foo diff --git a/collects/tests/scribble/text/o02.txt b/collects/tests/scribble/text/o02.txt deleted file mode 100644 index 405a0abf33..0000000000 --- a/collects/tests/scribble/text/o02.txt +++ /dev/null @@ -1,8 +0,0 @@ -Suggested price list for "PLT Scheme" - -0. PLT Scheme Home edition: $99.99 -1. PLT Scheme Professional edition: $149.99 -2. PLT Scheme Enterprize edition: $349.99 - -Total: 3 items -Average price: $199.99 diff --git a/collects/tests/scribble/text/o03.txt b/collects/tests/scribble/text/o03.txt deleted file mode 100644 index a23359348e..0000000000 --- a/collects/tests/scribble/text/o03.txt +++ /dev/null @@ -1,14 +0,0 @@ ----***--- -blah blah> blah - -blah, blah, blah, blah - -Warning: blah overdose might be fatal - -My name is zee Eli - ... and to that I say "Foo!", I think. - -My name is zee Eli - ... and to that I say "Foo!", I think. - -Repeating yourself much? diff --git a/collects/tests/scribble/text/o04.txt b/collects/tests/scribble/text/o04.txt deleted file mode 100644 index a132abf8d8..0000000000 --- a/collects/tests/scribble/text/o04.txt +++ /dev/null @@ -1,19 +0,0 @@ -begin - a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q -end diff --git a/collects/tests/scribble/text/o05.txt b/collects/tests/scribble/text/o05.txt deleted file mode 100644 index 219a2e7e9d..0000000000 --- a/collects/tests/scribble/text/o05.txt +++ /dev/null @@ -1,25 +0,0 @@ -function foo() { - if (1 < 2) - something1 - else - if (2<3) - something2 - else - something3 - fi - repeat 3 { - if (2<3) - something2 - else - something3 - fi - if (2<3) - something2.1 - something2.2 - else - something3 - fi - } - fi - return -} diff --git a/collects/tests/scribble/text/o06.txt b/collects/tests/scribble/text/o06.txt deleted file mode 100644 index 48c61d96f4..0000000000 --- a/collects/tests/scribble/text/o06.txt +++ /dev/null @@ -1,18 +0,0 @@ -function foo() { - prefix - if (1 < 2) - something1 - else - something2 - something3 - something4 - something5 - something6 - something7 - fi - return -} - -123 foo bar1 - bar2 - bar2 diff --git a/collects/tests/scribble/text/o07.txt b/collects/tests/scribble/text/o07.txt deleted file mode 100644 index e891777ab8..0000000000 --- a/collects/tests/scribble/text/o07.txt +++ /dev/null @@ -1,13 +0,0 @@ -function foo() { - var lst = [item1, - item2] - // comment1 - // comment2 - // comment3 - // comment4 - // comment5 - // comment6 - // * more - // * stuff - return -} diff --git a/collects/tests/scribble/text/o08.txt b/collects/tests/scribble/text/o08.txt deleted file mode 100644 index 4474770d83..0000000000 --- a/collects/tests/scribble/text/o08.txt +++ /dev/null @@ -1,10 +0,0 @@ -int blah() { - int var; -#ifdef FOO - var = [something, - something_else]; -#else - var = [something_else, - something]; -#endif -} diff --git a/collects/tests/scribble/text/o09.txt b/collects/tests/scribble/text/o09.txt deleted file mode 100644 index 583c738b1c..0000000000 --- a/collects/tests/scribble/text/o09.txt +++ /dev/null @@ -1,11 +0,0 @@ -start - * blah blah blah - | blah blah blah - | * more stuff - | | more stuff - | | more stuff - | blah blah blah - | blah blah blah - * more blah - blah blah -end diff --git a/collects/tests/scribble/text/o10.txt b/collects/tests/scribble/text/o10.txt deleted file mode 100644 index 50d405d59a..0000000000 --- a/collects/tests/scribble/text/o10.txt +++ /dev/null @@ -1,26 +0,0 @@ -function foo() { - // comment1 - // comment2 comment3 - // comment4 - var x = [item1, - item2] - bar1 - if (1 < 2) - something1 - something2 - something3 - else - if (2 < 3) - something_else - else - something_completely_different - fi - if (3 < 4) - another_something_else1 - another_something_else2 - else - another_something_completely_different - fi - fi - return; -} diff --git a/collects/tests/scribble/text/o11.txt b/collects/tests/scribble/text/o11.txt deleted file mode 100644 index 46bef0f064..0000000000 --- a/collects/tests/scribble/text/o11.txt +++ /dev/null @@ -1,7 +0,0 @@ -start - foo(); -loop: - if (something) { - blah(stuff); - } -end diff --git a/collects/tests/stepper/language-level-model.ss b/collects/tests/stepper/language-level-model.ss new file mode 100644 index 0000000000..f7983f888e --- /dev/null +++ b/collects/tests/stepper/language-level-model.ss @@ -0,0 +1,59 @@ +#lang scheme/base + +(require stepper/private/model-settings) + +(provide (all-defined-out)) + +;; DEFINING A LANGUAGE FOR THE PURPOSES OF TESTING + +;; ll-model : a representation of the behavior of a language level w.r.t. the stepper +(define-struct ll-model (namespace-spec teachpack-specs render-settings show-lambdas-as-lambdas? enable-testing?)) + +;; the built-in ll-models: +(define mz + (make-ll-model 'mzscheme `() fake-mz-render-settings #t #f)) + +(define beginner + (make-ll-model `(lib "htdp-beginner.ss" "lang") `() fake-beginner-render-settings #f #t)) + +(define beginner-wla + (make-ll-model `(lib "htdp-beginner-abbr.ss" "lang") `() fake-beginner-wla-render-settings #f #t)) + +(define intermediate + (make-ll-model `(lib "htdp-intermediate.ss" "lang") `() fake-intermediate-render-settings #f #t)) + +(define intermediate-lambda + (make-ll-model `(lib "htdp-intermediate-lambda.ss" "lang") `() fake-intermediate/lambda-render-settings #t #t)) + +(define advanced + (make-ll-model `(lib "htdp-advanced.ss" "lang") `() fake-advanced-render-settings #t #t)) + +(define lazy + (make-ll-model `(lib "lazy.ss" "lazy") `() fake-mz-render-settings #f #f)) + + +;; SUPPORT FOR TESTING A BUNCH OF LANGUAGES AT ONCE: + +;; built-in multi-language bundles: +(define upto-int/lam + (list beginner + beginner-wla + intermediate + intermediate-lambda)) + +(define upto-int + (list beginner + beginner-wla + intermediate)) + +(define bwla-to-int/lam + (list beginner-wla + intermediate + intermediate-lambda)) + +(define both-intermediates + (list intermediate + intermediate-lambda)) + + + diff --git a/collects/tests/stepper/test-engine.ss b/collects/tests/stepper/test-engine.ss new file mode 100644 index 0000000000..e15f99e676 --- /dev/null +++ b/collects/tests/stepper/test-engine.ss @@ -0,0 +1,241 @@ +#lang scheme + +(require stepper/private/shared + stepper/private/model + tests/utils/sexp-diff + lang/run-teaching-program + (only-in srfi/13 string-contains) + scheme/contract + #;(file "/Users/clements/clements/scheme-scraps/eli-debug.ss") + "language-level-model.ss") + + +;; A SIMPLE EXAMPLE OF USING THIS FRAMEWORK: + +;; note that this example uses the abbreviation from test-abbrev; don't uncomment it! + +#; +(let* ([defs1 `((define (a x) (+ x 5)) (define b a))] + [defs2 (append defs1 `((define c a)))]) + (apply ;; you can abstract over this application with a define-syntax + run-one-test + (tt 'top-ref4 ;; - the name of the test + m:intermediate ;; - the language level (or levels) to run in + ,@defs1 (define c b) (c 3) ;; - the expressions to test (everything up to the first ::) + :: ,@defs1 (define c {b}) ;; - the steps; the '::' divides steps, repeated '->'s indicate + -> ,@defs1 (define c {a}) ;; that the 'before' of the second step is the 'after' of + :: ,@defs2 ({c} 3) ;; the first one. the curly braces indicate the hilighted sexp. + -> ,@defs2 ({a} 3) + :: ,@defs2 {(a 3)} + -> ,@defs2 {(+ 3 5)} + -> ,@defs2 {8}))) + + + + +;; PARAMETERS THAT CONTROL TESTING + +(provide test-directory + display-only-errors + show-all-steps + disable-stepper-error-handling) + +(define test-directory (find-system-path 'temp-dir)) + +;; use this parameter to suppress output except in error cases: +(define display-only-errors (make-parameter #f)) + +;; use this parameter to show successful steps as well as unsuccessful ones: +(define show-all-steps (make-parameter #f)) + +;; use this parameter to prevent the stepper from capturing errors +;; (so that you can take advantage of DrScheme's error reporting) +(define disable-stepper-error-handling (make-parameter #f)) + +;; DATA DEFINITIONS: + +;; a step is one of +;; - `(before-after ,before ,after) where before and after are sexp-with-hilite's +;; - `(error ,err-msg) where err-msg is a string +;; - `(before-error ,before ,err-msg) where before is an sexp-with-hilite and err-msg is a string +;; - `(finished-stepping) +;; or +;; - `(ignore) +(define (step? sexp) + (match sexp + [(list 'before-after before after) #t] + [(list 'error (? string? msg)) #t] + [(list 'before-error before (? string? msg)) #t] + [(list 'finished-stepping) #t] + [(list 'ignore) #t] + [else #f])) + +;; a model-or-models is one of +;; - an ll-model, or +;; - (listof ll-model?) +(define model-or-models/c (or/c ll-model? (listof ll-model?))) + +;; THE METHOD THAT RUNS A TEST: + +(provide/contract [run-one-test (symbol? model-or-models/c string? (listof step?) . -> . boolean?)]) +;; run-one-test : symbol? model-or-models? string? steps? -> boolean? + +;; the ll-model determines the behavior of the stepper w.r.t. "language-level"-y things: +;; how should values be rendered, should steps be displayed (i.e, will the input & output +;; steps look just the same), etc. If + +;; the string contains a program to be evaluated. The string is an ironclad if blunt way +;; of ensuring that the program has no syntax information associated with it. + +;; the steps lists the desired steps. The easiest way to understand these is probably just to +;; read the code for the comparison given in "compare-steps", below. + +;; run the named test, return #t if a failure occurred during the test +(define (run-one-test name models exp-str expected-steps) + (unless (display-only-errors) + (printf "running test: ~v\n" name)) + (parameterize ([error-has-occurred-box (box #f)]) + (test-sequence/many models exp-str expected-steps) + (if (unbox (error-has-occurred-box)) + (begin (fprintf (current-error-port) "...Error has occurred during test: ~v\n" name) + #f) + #t))) + + +;; test-sequence/many : model-or-models/c string? steps? -> (void) +;; run a given test through a bunch of language models (or just one). + +(define (test-sequence/many models exp-str expected-steps) + (cond [(list? models)(for-each (lambda (model) (test-sequence model exp-str expected-steps)) + models)] + [else (test-sequence models exp-str expected-steps)])) + +;; test-sequence : ll-model? string? steps? -> (void) +;; given a language model and an expression and a sequence of steps, +;; check to see whether the stepper produces the desired steps +(define (test-sequence the-ll-model exp-str expected-steps) + (match the-ll-model + [(struct ll-model (namespace-spec teachpack-specs render-settings show-lambdas-as-lambdas? enable-testing?)) + (let ([filename (build-path test-directory "stepper-test")]) + (call-with-output-file filename + (lambda (port) (fprintf port "~a" exp-str)) + #:exists + 'truncate) + (unless (display-only-errors) + (printf "testing string: ~v\n" exp-str)) + (let* ([port (open-input-file filename)] + [module-id (gensym "stepper-module-name-")] + [expanded (expand-teaching-program port read-syntax namespace-spec teachpack-specs #f module-id enable-testing?)]) + (test-sequence/core render-settings show-lambdas-as-lambdas? expanded expected-steps)))])) + +;; test-sequence/core : render-settings? boolean? syntax? steps? +;; this is a front end for calling the stepper's "go"; the main +;; responsibility here is to fake the behavior of DrScheme and collect the +;; resulting steps. +(define (test-sequence/core render-settings show-lambdas-as-lambdas? expanded expected-steps) + (let* ([current-error-display-handler (error-display-handler)] + [all-steps + (append expected-steps '((finished-stepping)))] + [receive-result + (lambda (result) + (if (null? all-steps) + (warn 'test-sequence + "ran out of expected steps. Given result: ~v" result) + (begin + (if (compare-steps result (car all-steps)) + (when (and (show-all-steps) (not (display-only-errors))) + (printf "test-sequence: steps match for expected result: ~v\n" + (car all-steps))) + (warn 'test-sequence + "steps do not match\n given: ~v\nexpected: ~v" + (show-result result) (car all-steps))) + (set! all-steps (cdr all-steps)))))] + [iter-caller + (lambda (init iter) + (init) + (call-iter-on-each expanded iter))]) + (let/ec escape + (parameterize ([error-escape-handler (lambda () (escape (void)))]) + (go iter-caller receive-result render-settings + show-lambdas-as-lambdas? + ;; language level: + 'testing + ;; run-in-drscheme thunk: + (lambda (thunk) (thunk)) + (disable-stepper-error-handling)))) + (error-display-handler current-error-display-handler))) + +;; call-iter-on-each : (-> syntax?) (syntax? (-> 'a) -> 'a) -> void/c +;; call the given iter on each syntax-object in turn (iter bounces control) +;; back to us by calling the followup-thunk. +(define (call-iter-on-each stx-thunk iter) + (let* ([next (stx-thunk)] + [followup-thunk (if (eof-object? next) void (lambda () (call-iter-on-each stx-thunk iter)))]) + (iter (expand next) followup-thunk))) + +(define error-has-occurred-box (make-parameter #f)) + +(define (warn who fmt . args) + (set-box! (error-has-occurred-box) #t) + (fprintf (current-error-port) "~a: ~a\n" who (apply format fmt args))) + + +;; (-> step-result? sexp? boolean?) +(define (compare-steps actual expected) + (match expected + [`(before-after ,before ,after) + (and (before-after-result? actual) + (andmap (lambda (fn expected name) + (unless (list? (fn actual)) + (warn 'compare-steps "not a list: ~v" + (syntax-object->hilite-datum (fn actual)))) + (noisy-equal? (map syntax-object->hilite-datum + (fn actual)) + expected + name)) + (list before-after-result-pre-exps + before-after-result-post-exps) + (list before after) + (list 'before 'after)))] + [`(error ,err-msg) + (and (error-result? actual) + (string-contains (error-result-err-msg actual) err-msg))] + [`(before-error ,before ,err-msg) + (and (before-error-result? actual) + (and (noisy-equal? (map syntax-object->hilite-datum + (before-error-result-pre-exps actual)) + before + 'before) + (equal? err-msg (before-error-result-err-msg actual))))] + [`(finished-stepping) (finished-stepping? actual)] + [`(ignore) (warn 'compare-steps "ignoring one step") #t] + [else (begin (warn 'compare-steps + "unexpected expected step type: ~v" expected) + #f)])) + + + +;; used to display results in an error message +(define (show-result r) + (if (before-after-result? r) + (list 'before-after-result + (map (lambda (fn) + (unless (list? (fn r)) + (warn 'show-result "not a list: ~v" + (syntax-object->hilite-datum (fn r)))) + (map syntax-object->hilite-datum + (fn r))) + (list before-after-result-pre-exps + before-after-result-post-exps))) + r)) + +;; noisy-equal? : (any any . -> . boolean) +;; like equal?, but prints a noisy error message +(define (noisy-equal? actual expected name) + (if (equal? actual expected) + #t + (begin (warn 'not-equal? + "~e:\nactual: ~e =/= \nexpected: ~e\n here's the diff: ~e" name actual expected (sexp-diff actual expected)) + #f))) + + diff --git a/collects/tests/stepper/through-tests.ss b/collects/tests/stepper/through-tests.ss index 0799b97919..7fb258926b 100755 --- a/collects/tests/stepper/through-tests.ss +++ b/collects/tests/stepper/through-tests.ss @@ -1,988 +1,716 @@ -#lang scheme/base +#lang scheme - (require (for-syntax scheme/base) - (for-syntax scheme/mpair) - scheme/match - stepper/private/shared - stepper/private/model - stepper/private/model-settings - tests/utils/sexp-diff - lang/run-teaching-program - (only-in srfi/13 string-contains) - ;; for xml testing: - ;; mzlib/class - ;; (all-except xml/xml-snipclass snip-class) - ;; (all-except xml/scheme-snipclass snip-class) - ;; mred - #;(file "/Users/clements/clements/scheme-scraps/eli-debug.ss") - ) - - (provide (all-defined-out)) +(require stepper/private/model-settings + (prefix-in m: "language-level-model.ss") + "test-engine.ss" + "test-abbrev.ss" + + ;; for xml testing: + ;; mzlib/class + ;; (all-except xml/xml-snipclass snip-class) + ;; (all-except xml/scheme-snipclass snip-class) + ;; mred - (define test-directory (find-system-path 'temp-dir)) - - (define display-only-errors (make-parameter #f)) - - (define error-has-occurred-box (make-parameter #f)) - - (define show-all-steps (make-parameter #f)) + ) - (define disable-stepper-error-handling (make-parameter #f)) - - (define (stream-ify stx-thunk iter) - (lambda () - (let* ([next (stx-thunk)] - [followup-thunk (if (eof-object? next) void (stream-ify stx-thunk iter))]) - (iter (expand next) followup-thunk)))) +(define list-of-tests null) - (define (warn who fmt . args) - (set-box! (error-has-occurred-box) #t) - (fprintf (current-error-port) "~a: ~a\n" who (apply format fmt args))) +(define (add-test test) + (match test + [(list name models string expected-steps) + (when (assq name list-of-tests) + (error 'add-test "name ~v is already in the list of tests" name)) + (set! list-of-tests (append list-of-tests (list (list name (list models string expected-steps)))))])) - (define (test-sequence-core namespace-spec teachpack-specs render-settings - show-lambdas-as-lambdas? enable-testing? in-port expected-steps) - (let* ([current-error-display-handler (error-display-handler)] - [all-steps - (append expected-steps '((finished-stepping)))] - [receive-result - (lambda (result) - (if (null? all-steps) - (warn 'test-sequence - "ran out of expected steps. Given result: ~v" result) - (begin - (if (compare-steps result (car all-steps)) - (when (and (show-all-steps) (not (display-only-errors))) - (printf "test-sequence: steps match for expected result: ~v\n" - (car all-steps))) - (warn 'test-sequence - "steps do not match\n given: ~v\nexpected: ~v" - (show-result result) (car all-steps))) - (set! all-steps (cdr all-steps)))))] - [program-expander - (let ([module-id (gensym "stepper-module-name-")]) - (lambda (init iter) - (init) - ((stream-ify (expand-teaching-program in-port read-syntax namespace-spec teachpack-specs #f module-id enable-testing?) iter))))]) - (let/ec escape - (parameterize ([error-escape-handler (lambda () (escape (void)))]) - (go program-expander receive-result render-settings - show-lambdas-as-lambdas? - ;; language level: - 'testing - ;; run-in-drscheme thunk: - (lambda (thunk) (thunk)) - (disable-stepper-error-handling)))) - (error-display-handler current-error-display-handler))) +(define (t1 name models string expected-steps) + (add-test (list name models string expected-steps))) - (define (test-sequence namespace-spec teachpack-specs render-settings - show-lambdas-as-lambdas? enable-testing? exp-str expected-steps) - (let ([filename (build-path test-directory "stepper-test")]) - (call-with-output-file filename - (lambda (port) (fprintf port "~a" exp-str)) - #:exists - 'truncate) - (unless (display-only-errors) - (printf "testing string: ~v\n" exp-str)) - (letrec ([port (open-input-file filename)]) - (test-sequence-core namespace-spec teachpack-specs render-settings - show-lambdas-as-lambdas? enable-testing? port expected-steps)))) +;; one more layer around +(define-syntax (t stx) + (syntax-case stx () + [(_ . rest) + (quasisyntax/loc stx + (add-test (tt . rest)))])) - (define (lang-level-test-sequence namespace-spec rs show-lambdas-as-lambdas? enable-testing?) - (lambda args - (apply test-sequence namespace-spec `() rs show-lambdas-as-lambdas? enable-testing? args))) +;; run a test : (list symbol test-thunk) -> boolean +;; run the named test, return #t if a failure occurred during the test +(define (run-one-test/helper test-pair) + (apply run-one-test (car test-pair) (cadr test-pair))) - (define (make-multi-level-test-sequence level-fns) - (lambda args - (for-each (lambda (fn) (apply fn args)) level-fns))) +(define (run-all-tests) + (andmap/no-shortcut + run-one-test/helper + list-of-tests)) - (define test-mz-sequence - (lang-level-test-sequence 'mzscheme fake-mz-render-settings #t #f)) - (define test-beginner-sequence - (lang-level-test-sequence `(lib "htdp-beginner.ss" "lang") - fake-beginner-render-settings #f #t)) - (define test-beginner-wla-sequence - (lang-level-test-sequence `(lib "htdp-beginner-abbr.ss" "lang") - fake-beginner-wla-render-settings #f #t)) - (define test-intermediate-sequence - (lang-level-test-sequence `(lib "htdp-intermediate.ss" "lang") - fake-intermediate-render-settings #f #t)) - (define test-intermediate/lambda-sequence - (lang-level-test-sequence `(lib "htdp-intermediate-lambda.ss" "lang") - fake-intermediate/lambda-render-settings #t #t)) - (define test-advanced-sequence - (lang-level-test-sequence `(lib "htdp-advanced.ss" "lang") - fake-advanced-render-settings #t #t)) +(define (run-all-tests-except nix-list) + (andmap/no-shortcut + run-one-test/helper + (filter (lambda (pr) (not (member (car pr) nix-list))) + list-of-tests))) - (define test-upto-int/lam - (make-multi-level-test-sequence - (list test-beginner-sequence - test-beginner-wla-sequence - test-intermediate-sequence - test-intermediate/lambda-sequence))) +(define (run-test name) + (let ([maybe-test (assq name list-of-tests)]) + (if maybe-test + (run-one-test/helper maybe-test) + (error 'run-test "test not found: ~e" name)))) - (define test-upto-int - (make-multi-level-test-sequence - (list test-beginner-sequence - test-beginner-wla-sequence - test-intermediate-sequence))) +(define (run-tests names) + (ormap/no-shortcut run-test names)) - (define test-bwla-to-int/lam - (make-multi-level-test-sequence - (list test-beginner-wla-sequence - test-intermediate-sequence - test-intermediate/lambda-sequence))) - (define test-both-ints - (make-multi-level-test-sequence - (list test-intermediate-sequence - test-intermediate/lambda-sequence))) +;; like an ormap, but without short-cutting +(define (ormap/no-shortcut f args) + (foldl (lambda (a b) (or a b)) #f (map f args))) - (define test-lazy-sequence - (lang-level-test-sequence `(lib "lazy.ss" "lazy") - fake-mz-render-settings #f #f)) +(define (andmap/no-shortcut f args) + (foldl (lambda (a b) (and a b)) #t (map f args))) - ;; mutate these to values you want to examine in the repl: - (define bell-jar-specimen-1 #f) - (define bell-jar-specimen-2 #f) +(t 'mz1 m:mz + (for-each (lambda (x) x) '(1 2 3)) + :: {(for-each (lambda (x) x) `(1 2 3))} -> (... {1} ...) + :: ... -> (... {2} ...) + :: ... -> (... {3} ...) + :: ... -> {(void)}) - ;; so->d/finished : call (syntax-object->hilite-datum stx #t). For finished - ;; steps, we want to ignore the highlight but not the xml boxes (and other - ;; future stuff?) - (define (so->d/finished stx) - (syntax-object->hilite-datum stx #t)) +;; new test case language: +;; an expected is (listof step) +;; a step is one of +;; (before-after exps exps) +;; (before-error exps str) +;; (error str) +;; (finished) +;; an exps is a list of s-expressions with certain non-hygienic extensions: +;; - (hilite X) denotes the s-expression X, only highlighted +;; - any denotes any s-expression (matches everything) +;; ... in principle, these could collide with programs that use the +;; identifiers 'hilite' and 'any', but since I'm writing the test cases, +;; I can alpha-rename manually to avoid collisions. - ;; (-> step-result? sexp? boolean?) - (define (compare-steps actual expected) - (match expected - [`(before-after ,before ,after) - (and (before-after-result? actual) - (andmap (lambda (fn expected name) - (unless (list? (fn actual)) - (warn 'compare-steps "not a list: ~v" - (syntax-object->hilite-datum (fn actual)))) - (noisy-equal? (map syntax-object->hilite-datum - (fn actual)) - expected - name)) - (list before-after-result-pre-exps - before-after-result-post-exps) - (list before after) - (list 'before 'after)))] - [`(error ,err-msg) - (and (error-result? actual) - (string-contains (error-result-err-msg actual) err-msg))] - [`(before-error ,before ,err-msg) - (and (before-error-result? actual) - (and (noisy-equal? (map syntax-object->hilite-datum - (before-error-result-pre-exps actual)) - before - 'before) - (equal? err-msg (before-error-result-err-msg actual))))] - [`(finished-stepping) (finished-stepping? actual)] - [`(ignore) (warn 'compare-steps "ignoring one step") #t] - [else (begin (warn 'compare-steps - "unexpected expected step type: ~v" expected) - #f)])) - - ;; used to display results in an error message - (define (show-result r) - (if (before-after-result? r) - (list 'before-after-result - (map (lambda (fn) - (unless (list? (fn r)) - (warn 'show-result "not a list: ~v" - (syntax-object->hilite-datum (fn r)))) - (map syntax-object->hilite-datum - (fn r))) - (list before-after-result-pre-exps - before-after-result-post-exps))) - r)) +;; on top of this, the `t' macro makes things easier to write, informally: +;; (t 'name ; symbolic name for the test +;; tester ; tester function that gets used +;; expr1 ... :: expr2 ... -> expr3 ...) +;; means that `expr1 ...' is the original, the first step is +;; (before-after (expr2 ...) (expr3 ...)) +;; Cute stuff: +;; * use `::' to mark a new step that doesn't continue the previous one +;; e1 :: e2 -> e3 -> e4 +;; is the same as +;; e1 :: e2 -> e3 :: e3 -> e4 +;; * use `-> error: "..."' for a `before-error' step +;; * use `:: error: "..."' for an `error' step +;; * a `finished-stepping' is added if no error was specified +;; * a `{...}' is replaced with `(hilite ...)' - ;; noisy-equal? : (any any . -> . boolean) - ;; like equal?, but prints a noisy error message - (define (noisy-equal? actual expected name) - (if (equal? actual expected) - #t - (begin (warn 'not-equal? - "~e:\nactual: ~e =/= \nexpected: ~e\n here's the diff: ~e" name actual expected (sexp-diff actual expected)) - #f))) +(t 'mz-app m:mz + (+ 3 4) + :: {(+ 3 4)} -> {7}) - ;; (-> (listof sexp) (listof sexp) boolean?) - (define (compare-finished finished-exps expected-exps) - (and (>= (length finished-exps) (length expected-exps)) - (andmap (lambda (x y) - (if (equal? x y) - #t - (begin - (warn 'not-equal? - "~e =/= ~e\n here's the diff: ~e" - x y (sexp-diff x y)) - #f))) - (list-tail finished-exps - (- (length finished-exps) (length expected-exps))) - expected-exps))) +(t 'mz-app2 m:mz + ((lambda (x) (+ x 3)) 4) + :: {((lambda (x) (+ x 3)) 4)} -> {(+ 4 3)} -> {7}) - ;; (-> (listof sexp) string?) - (define (exprs->string exprs) - (apply string-append - (cdr (apply append (map (lambda (x) (list " " (format "~s" x))) - exprs))))) +(t 'mz-if m:mz + (if 3 4 5) + :: {(if 3 4 5)} -> {4}) - (define list-of-tests null) +(t 'simple-if m:upto-int/lam + (if true false true) + :: {(if true false true)} -> {false}) - (define (add-test name thunk) - (when (assq name list-of-tests) - (error 'add-test "name ~v is already in the list of tests" name)) - (set! list-of-tests (append list-of-tests (list (list name thunk))))) +(t 'if-bool m:upto-int/lam + (if (if true false true) false true) + :: (if {(if true false true)} false true) -> (if {false} false true) + :: {(if false false true)} -> {true}) - (define-syntax (t1 stx) - (syntax-case stx () - [(_ name test) - (syntax/loc stx (add-test `name (lambda () test)))])) - - ;; Eli can't help adding his own convenient but complex syntax here (JBC, 2006-11-14): +(t 'direct-app m:mz + ((lambda (x) x) 3) + :: {((lambda (x) x) 3)} -> {3}) - (define-syntax (t stx) - (define (maybe-mlist->list r) - (if (mpair? r) - (mlist->list r) - r)) - (define (split l) - (let loop ([l l] [r '()]) - (cond [(null? l) (reverse (map maybe-mlist->list r))] - [(symbol? (car l)) (loop (cdr l) (cons (car l) r))] - [(or (null? r) (not (mpair? (car r)))) - (loop (cdr l) (cons (mlist (car l)) r))] - [else (mappend! (car r) (mlist (car l))) - (loop (cdr l) r)]))) - (define (process-hilites s) - (syntax-case s () - [(x) (eq? #\{ (syntax-property s 'paren-shape)) - (with-syntax ([x (process-hilites #'x)]) #'(hilite x))] - [(x . y) (let* ([x0 #'x] - [y0 #'y] - [x1 (process-hilites #'x)] - [y1 (process-hilites #'y)]) - (if (and (eq? x0 x1) (eq? y0 y1)) - s - (with-syntax ([x x1] [y y1]) #'(x . y))))] - [_else s])) - (define (process stx) - (split (map (lambda (s) - (if (and (identifier? s) - (memq (syntax-e s) '(:: -> error:))) - (syntax-e s) - (process-hilites s))) - (syntax->list stx)))) - (define (parse l) - (syntax-case l (::) - [(fst :: rest ...) - (cons #'fst - (let loop ([rest #'(rest ...)]) - (syntax-case rest (:: -> error:) - [(error: (err)) (list #'(error err))] - [() (list #'(finished-stepping))] - [(x -> y) (list #'(before-after x y) #'(finished-stepping))] - [(x -> error: (err)) (list #'(before-error x err))] - [(x -> y :: . rest) - (cons #'(before-after x y) (loop #'rest))] - [(x -> y -> . rest) - (cons #'(before-after x y) (loop #'(y -> . rest)))])))])) - (syntax-case stx (::) - [(_ name tester . rest) - (with-syntax ([(exprs arg ...) (parse (process #'rest))]) - (quasisyntax/loc stx - (add-test `name - (lambda () - (tester - ;printf "exprs = ~s\n args = ~s\n" - (exprs->string `exprs) `(arg ...))))))])) - - ;; run a test : (list symbol test-thunk) -> boolean - ;; run the named test, return #t if a failure occurred during the test - (define (run-one-test test-pair) - (unless (display-only-errors) - (printf "running test: ~v\n" (car test-pair))) - (parameterize ([error-has-occurred-box (box #f)]) - ((cadr test-pair)) - (if (unbox (error-has-occurred-box)) - (begin (fprintf (current-error-port) "...Error has occurred during test: ~v\n" (car test-pair)) - #t) - #f))) - - (define (run-all-tests) - (ormap/no-shortcut - run-one-test - list-of-tests)) - - (define (run-all-tests-except nix-list) - (ormap/no-shortcut - run-one-test - (filter (lambda (pr) (not (member (car pr) nix-list))) - list-of-tests))) - - (define (run-test name) - (let ([maybe-test (assq name list-of-tests)]) - (if maybe-test - (run-one-test maybe-test) - (error 'run-test "test not found: ~e" name)))) - - (define (run-tests names) - (ormap/no-shortcut run-test names)) - - - ;; like an ormap, but without short-cutting - (define (ormap/no-shortcut f args) - (foldl (lambda (a b) (or a b)) #f (map f args))) - - (t mz1 test-mz-sequence - (for-each (lambda (x) x) '(1 2 3)) - :: {(for-each (lambda (x) x) `(1 2 3))} -> (... {1} ...) - :: ... -> (... {2} ...) - :: ... -> (... {3} ...) - :: ... -> {(void)}) - - ;; new test case language: - ;; an expected is (listof step) - ;; a step is one of - ;; (before-after exps exps) - ;; (before-error exps str) - ;; (error str) - ;; (finished) - ;; an exps is a list of s-expressions with certain non-hygienic extensions: - ;; - (hilite X) denotes the s-expression X, only highlighted - ;; - any denotes any s-expression (matches everything) - ;; ... in principle, these could collide with programs that use the - ;; identifiers 'hilite' and 'any', but since I'm writing the test cases, - ;; I can alpha-rename manually to avoid collisions. - - ;; on top of this, the `t' macro makes things easier to write, informally: - ;; (t name ; symbolic name for the test - ;; tester ; tester function that gets used - ;; expr1 ... :: expr2 ... -> expr3 ...) - ;; means that `expr1 ...' is the original, the first step is - ;; (before-after (expr2 ...) (expr3 ...)) - ;; Cute stuff: - ;; * use `::' to mark a new step that doesn't continue the previous one - ;; e1 :: e2 -> e3 -> e4 - ;; is the same as - ;; e1 :: e2 -> e3 :: e3 -> e4 - ;; * use `-> error: "..."' for a `before-error' step - ;; * use `:: error: "..."' for an `error' step - ;; * a `finished-stepping' is added if no error was specified - ;; * a `{...}' is replaced with `(hilite ...)' - - (t mz-app test-mz-sequence - (+ 3 4) - :: {(+ 3 4)} -> {7}) - - (t mz-app2 test-mz-sequence - ((lambda (x) (+ x 3)) 4) - :: {((lambda (x) (+ x 3)) 4)} -> {(+ 4 3)} -> {7}) - - (t mz-if test-mz-sequence - (if 3 4 5) - :: {(if 3 4 5)} -> {4}) - - (t simple-if test-upto-int/lam - (if true false true) - :: {(if true false true)} -> {false}) - - (t if-bool test-upto-int/lam - (if (if true false true) false true) - :: (if {(if true false true)} false true) -> (if {false} false true) - :: {(if false false true)} -> {true}) - - (t direct-app test-mz-sequence - ((lambda (x) x) 3) - :: {((lambda (x) x) 3)} -> {3}) - -; (test-mz-sequence "((lambda (x) x) (begin (+ 3 4) (+ 4 5)))" +; (m:mz "((lambda (x) x) (begin (+ 3 4) (+ 4 5)))" ; `((before-after ((begin (hilite (+ 3 4)) (+ 4 5))) ; ((begin (hilite 7) (+ 4 5)))) ; (before-after ((hilite (begin 7 (+ 4 5)))) ((hilite (+ 4 5)))) ; (before-after ((hilite (+ 4 5))) ((hilite 9))) ; (finished-stepping))) - (t curried test-mz-sequence - ((lambda (a) (lambda (b) (+ a b))) 14) - :: {((lambda (a) (lambda (b) (+ a b))) 14)} - -> {(lambda (b) (+ 14 b))}) +(t 'curried m:mz + ((lambda (a) (lambda (b) (+ a b))) 14) + :: {((lambda (a) (lambda (b) (+ a b))) 14)} + -> {(lambda (b) (+ 14 b))}) - (t case-lambda test-mz-sequence - ((case-lambda ((a) 3) ((b c) (+ b c))) 5 6) - :: {((case-lambda ((a) 3) ((b c) (+ b c))) 5 6)} - -> {(+ 5 6)} - -> {11}) +(t 'case-lambda m:mz + ((case-lambda ((a) 3) ((b c) (+ b c))) 5 6) + :: {((case-lambda ((a) 3) ((b c) (+ b c))) 5 6)} + -> {(+ 5 6)} + -> {11}) - ;; not really a part of base mzscheme anymore - #;(t 2armed-if test-mz-sequence +;; not really a part of base mzscheme anymore +#;(t '2armed-if m:mz (if 3 4) :: {(if 3 4)} -> {4}) - ;(test-mz-sequence "((call-with-current-continuation call-with-current-continuation) (call-with-current-continuation call-with-current-continuation))" - ; `((before-after (((hilite ,h-p) (call-with-current-continuation call-with-current-continuation))) ((call-with-current-continuation call-with-current-continuation)) - ; (((hilite ,h-p) (call-with-current-continuation call-with-current-continuation))) ((lambda args ...))) - ; (before-after (((lambda args ...) (hilite ,h-p))) ((call-with-current-continuation call-with-current-continuation)) - ; (((lambda args ...) (hilite ,h-p))) ((lambda args ...))))) +;(m:mz "((call-with-current-continuation call-with-current-continuation) (call-with-current-continuation call-with-current-continuation))" +; `((before-after (((hilite ,h-p) (call-with-current-continuation call-with-current-continuation))) ((call-with-current-continuation call-with-current-continuation)) +; (((hilite ,h-p) (call-with-current-continuation call-with-current-continuation))) ((lambda args ...))) +; (before-after (((lambda args ...) (hilite ,h-p))) ((call-with-current-continuation call-with-current-continuation)) +; (((lambda args ...) (hilite ,h-p))) ((lambda args ...))))) - ;(test-mz-sequence '(begin (define g 3) g) - ; `((before-after ((hilite ,h-p)) (g) - ; ((hilite ,h-p)) 3))) +;(m:mz '(begin (define g 3) g) +; `((before-after ((hilite ,h-p)) (g) +; ((hilite ,h-p)) 3))) - ;(syntax-object->datum (cadr (annotate-expr test2 'mzscheme 0 (lambda (x) x)))) +;(syntax-object->datum (cadr (annotate-expr test2 'mzscheme 0 (lambda (x) x)))) - (t top-def test-upto-int/lam - (define a (+ 3 4)) - :: (define a {(+ 3 4)}) - -> (define a {7})) +(t 'top-def m:upto-int/lam + (define a (+ 3 4)) + :: (define a {(+ 3 4)}) + -> (define a {7})) - (t top-def-ref test-upto-int/lam - (define a 6) a - :: (define a 6) {a} -> (define a 6) {6}) +(t 'top-def-ref m:upto-int/lam + (define a 6) a + :: (define a 6) {a} -> (define a 6) {6}) - (t app test-upto-int/lam - (+ 4 129) - :: {(+ 4 129)} -> {133}) +(t 'app m:upto-int/lam + (+ 4 129) + :: {(+ 4 129)} -> {133}) - (t if test-upto-int/lam (if true 3 4) - :: {(if true 3 4)} -> {3}) +(t 'if m:upto-int/lam (if true 3 4) + :: {(if true 3 4)} -> {3}) - (let ([def `(define (a3 x) (if true x x))]) - (t top-app test-upto-int - ,def (a3 false) - :: ,def {(a3 false)} - -> ,def {(if true false false)} - -> ,def {false}) - ;; - (t top-app/lam test-intermediate/lambda-sequence - ,def (a3 false) - :: ,def ({a3} false) - -> ,def ({(lambda (x) (if true x x))} false) - :: ,def {((lambda (x) (if true x x)) false)} - -> ,def {(if true false false)} - -> ,def {false})) - - (let ([defs `((define (a12 x) (+ x 9)) (define b12 a12))]) - (t top-interref test-intermediate-sequence - ,@defs (b12 12) - :: ,@defs ({b12} 12) - -> ,@defs ({a12} 12) - :: ,@defs {(a12 12)} - -> ,@defs {(+ 12 9)} - -> ,@defs {21})) - - ;;;;;;;;;;;; +(let ([def `(define (a3 x) (if true x x))]) + (t 'top-app m:upto-int + ,def (a3 false) + :: ,def {(a3 false)} + -> ,def {(if true false false)} + -> ,def {false}) ;; - ;; OR / AND + (t 'top-app/lam m:intermediate-lambda + ,def (a3 false) + :: ,def ({a3} false) + -> ,def ({(lambda (x) (if true x x))} false) + :: ,def {((lambda (x) (if true x x)) false)} + -> ,def {(if true false false)} + -> ,def {false})) + +(let ([defs `((define (a12 x) (+ x 9)) (define b12 a12))]) + (t 'top-interref m:intermediate + ,@defs (b12 12) + :: ,@defs ({b12} 12) + -> ,@defs ({a12} 12) + :: ,@defs {(a12 12)} + -> ,@defs {(+ 12 9)} + -> ,@defs {21})) + +;;;;;;;;;;;; +;; +;; OR / AND +;; +;;;;;;;;;;;;;. + +(t 'or1 m:upto-int/lam + (or false true false) + :: {(or false true false)} -> {true}) + +(t 'and1 m:upto-int/lam + (and true false true) + :: {(and true false true)} -> {false}) + +(t 'and2 m:upto-int/lam + (and true (if true true false)) + :: (and true {(if true true false)}) -> (and true {true}) + :: {(and true true)} -> {true}) + +(let ([def `(define (b2 x) (and true x))]) + (t 'and3 m:upto-int + ,def (b2 false) + :: ,def {(b2 false)} + -> ,def {(and true false)} + -> ,def {false}) ;; - ;;;;;;;;;;;;;. + (t 'and3/lam m:intermediate-lambda + (define (b2 x) (and true x)) (b2 false) + :: ,def ({b2} false) + -> ,def ({(lambda (x) (and true x))} false) + :: ,def {((lambda (x) (and true x)) false)} + -> ,def {(and true false)} + -> ,def {false})) - (t or1 test-upto-int/lam - (or false true false) - :: {(or false true false)} -> {true}) - - (t and1 test-upto-int/lam - (and true false true) - :: {(and true false true)} -> {false}) - - (t and2 test-upto-int/lam - (and true (if true true false)) - :: (and true {(if true true false)}) -> (and true {true}) - :: {(and true true)} -> {true}) - - (let ([def `(define (b2 x) (and true x))]) - (t and3 test-upto-int - ,def (b2 false) - :: ,def {(b2 false)} - -> ,def {(and true false)} - -> ,def {false}) - ;; - (t and3/lam test-intermediate/lambda-sequence - (define (b2 x) (and true x)) (b2 false) - :: ,def ({b2} false) - -> ,def ({(lambda (x) (and true x))} false) - :: ,def {((lambda (x) (and true x)) false)} - -> ,def {(and true false)} - -> ,def {false})) - - (let ([defs `((define a1 true) - (define (b1 x) (and a1 true x)))]) - (t and4 test-upto-int - ,@defs (b1 false) - :: ,@defs {(b1 false)} - -> ,@defs {(and a1 true false)} - :: ,@defs (and {a1} true false) - -> ,@defs (and {true} true false) - :: ,@defs {(and true true false)} - -> ,@defs {false}) - ;; - (t and4/lam test-intermediate/lambda-sequence - ,@defs (b1 false) - :: ,@defs ({b1} false) - -> ,@defs ({(lambda (x) (and a1 true x))} false) - :: ,@defs {((lambda (x) (and a1 true x)) false)} - -> ,@defs {(and a1 true false)} - :: ,@defs (and {a1} true false) - -> ,@defs (and {true} true false) - :: ,@defs {(and true true false)} - -> ,@defs {false})) - - (t bad-and test-upto-int/lam - (and true 1) - :: {(and true 1)} - -> error: "and: question result is not true or false: 1") - - ;;;;;;;;;;;;; +(let ([defs `((define a1 true) + (define (b1 x) (and a1 true x)))]) + (t 'and4 m:upto-int + ,@defs (b1 false) + :: ,@defs {(b1 false)} + -> ,@defs {(and a1 true false)} + :: ,@defs (and {a1} true false) + -> ,@defs (and {true} true false) + :: ,@defs {(and true true false)} + -> ,@defs {false}) ;; - ;; COND - ;; - ;;;;;;;;;;;;; + (t 'and4/lam m:intermediate-lambda + ,@defs (b1 false) + :: ,@defs ({b1} false) + -> ,@defs ({(lambda (x) (and a1 true x))} false) + :: ,@defs {((lambda (x) (and a1 true x)) false)} + -> ,@defs {(and a1 true false)} + :: ,@defs (and {a1} true false) + -> ,@defs (and {true} true false) + :: ,@defs {(and true true false)} + -> ,@defs {false})) - (t cond1 test-upto-int/lam - (cond [false 4] [false 5] [true 3]) - :: {(cond (false 4) (false 5) (true 3))} - -> {(cond (false 5) (true 3))} - -> {(cond (true 3))} - -> {3}) +(t 'bad-and m:upto-int/lam + (and true 1) + :: {(and true 1)} + -> error: "and: question result is not true or false: 1") - (t cond-else test-upto-int/lam - (cond [false 4] [else 9]) - :: {(cond [false 4] [else 9])} - -> {(cond [else 9])} - -> {9}) +;;;;;;;;;;;;; +;; +;; COND +;; +;;;;;;;;;;;;; - (t cond-andelse test-upto-int/lam - (cond [true 3] [else (and true true)]) - :: {(cond (true 3) (else (and true true)))} -> {3}) +(t 'cond1 m:upto-int/lam + (cond [false 4] [false 5] [true 3]) + :: {(cond (false 4) (false 5) (true 3))} + -> {(cond (false 5) (true 3))} + -> {(cond (true 3))} + -> {3}) - (t bad-cond test-upto-int/lam - (cond) - :: error: "cond: expected a question--answer clause after `cond', but nothing's there") +(t 'cond-else m:upto-int/lam + (cond [false 4] [else 9]) + :: {(cond [false 4] [else 9])} + -> {(cond [else 9])} + -> {9}) - (t just-else test-upto-int/lam - (cond [else 3]) - :: {(cond (else 3))} -> {3}) +(t 'cond-andelse m:upto-int/lam + (cond [true 3] [else (and true true)]) + :: {(cond (true 3) (else (and true true)))} -> {3}) - (t nested-cond test-upto-int/lam - (cond [else (cond [else 3])]) - :: {(cond (else (cond (else 3))))} - -> {(cond (else 3))} - -> {3}) +(t 'bad-cond m:upto-int/lam + (cond) + :: error: "cond: expected a question--answer clause after `cond', but nothing's there") - ;; reconstruct can't handle 'begin' - #; - (test-mz-sequence "(cond [#f 3 4] [#t (+ 3 4) (+ 4 9)])" - `((before-after ((hilite (cond (#f 3 4) (#t (+ 3 4) (+ 4 9))))) - ((hilite (cond (#t (+ 3 4) (+ 4 9)))))) - (before-after ((hilite (cond (#t (+ 3 4) (+ 4 9))))) - ((hilite (begin (+ 3 4) (+ 4 9))))) - (before-after ((begin (hilite (+ 3 4)) (+ 4 9))) - ((begin (hilite 7) (+ 4 9)))) - (before-after ((hilite (begin 7 (+ 4 9)))) - ((hilite (+ 4 9)))) - (before-after ((hilite (+ 4 9))) - ((hilite 13))) +(t 'just-else m:upto-int/lam + (cond [else 3]) + :: {(cond (else 3))} -> {3}) + +(t 'nested-cond m:upto-int/lam + (cond [else (cond [else 3])]) + :: {(cond (else (cond (else 3))))} + -> {(cond (else 3))} + -> {3}) + +;; reconstruct can't handle 'begin' +#; +(m:mz "(cond [#f 3 4] [#t (+ 3 4) (+ 4 9)])" + `((before-after ((hilite (cond (#f 3 4) (#t (+ 3 4) (+ 4 9))))) + ((hilite (cond (#t (+ 3 4) (+ 4 9)))))) + (before-after ((hilite (cond (#t (+ 3 4) (+ 4 9))))) + ((hilite (begin (+ 3 4) (+ 4 9))))) + (before-after ((begin (hilite (+ 3 4)) (+ 4 9))) + ((begin (hilite 7) (+ 4 9)))) + (before-after ((hilite (begin 7 (+ 4 9)))) + ((hilite (+ 4 9)))) + (before-after ((hilite (+ 4 9))) + ((hilite 13))) + (finished-stepping))) + +(t 'nested-cond2 m:upto-int/lam + (cond [false 3] [else (cond [true 4])]) + :: {(cond (false 3) (else (cond (true 4))))} + -> {(cond (else (cond (true 4))))} + -> {(cond (true 4))} + -> {4}) + +(t 'top-ref m:intermediate + (define a4 +) a4 + :: (define a4 +) {a4} + -> (define a4 +) {+}) + +(t 'top-ref2 m:intermediate + (define (f123 x) (+ x 13)) f123 + ::) + +(t 'top-ref3 m:intermediate-lambda + (define (f123 x) (+ x 13)) f123 + :: (define (f123 x) (+ x 13)) {f123} + -> (define (f123 x) (+ x 13)) {(lambda (x) (+ x 13))}) + +(let* ([defs1 `((define (a x) (+ x 5)) (define b a))] + [defs2 (append defs1 `((define c a)))]) + (t 'top-ref4 m:intermediate + ,@defs1 (define c b) (c 3) + :: ,@defs1 (define c {b}) + -> ,@defs1 (define c {a}) + :: ,@defs2 ({c} 3) + -> ,@defs2 ({a} 3) + :: ,@defs2 {(a 3)} + -> ,@defs2 {(+ 3 5)} + -> ,@defs2 {8})) + +(t 'define-struct m:upto-int/lam + (define-struct mamba (rhythm tempo)) (mamba-rhythm (make-mamba 24 2)) + :: (define-struct mamba (rhythm tempo)) {(mamba-rhythm (make-mamba 24 2))} + -> (define-struct mamba (rhythm tempo)) {24}) + +(let ([def `(define a5 (lambda (a5) (+ a5 13)))]) + (t 'lam-def m:upto-int + ,def (a5 23) + :: ,def {(a5 23)} + -> ,def {(+ 23 13)} + -> ,def {36})) + +(let ([def `(define a5 (lambda (a5) (+ a5 13)))]) + (t 'lam-def/lam m:intermediate-lambda + ,def (a5 23) + :: ,def ({a5} 23) + -> ,def ({(lambda (a5) (+ a5 13))} 23) + :: ,def {((lambda (a5) (+ a5 13)) 23)} + -> ,def {(+ 23 13)} + -> ,def {36})) + +(let ([def `(define a_0 (lambda (x) (+ x 5)))]) + (t 'lam-let m:intermediate + (let ([a (lambda (x) (+ x 5))]) (a 6)) + :: {(let ([a (lambda (x) (+ x 5))]) (a 6))} + -> {(define a_0 (lambda (x) (+ x 5)))} {(a_0 6)} + :: ,def {(a_0 6)} + -> ,def {(+ 6 5)} + -> ,def {11})) + +(let ([defs `((define c1 false) + (define (d2 x) (or c1 false x)))]) + (t 'whocares m:upto-int + ,@defs (d2 false) + :: ,@defs {(d2 false)} + -> ,@defs {(or c1 false false)} + :: ,@defs (or {c1} false false) + -> ,@defs (or {false} false false) + :: ,@defs {(or false false false)} + -> ,@defs {false})) + +(let ([defs `((define c1 false) + (define (d2 x) (or c1 false x)))]) + (t 'whocares/lam m:intermediate-lambda + ,@defs (d2 false) + :: ,@defs ({d2} false) + -> ,@defs ({(lambda (x) (or c1 false x))} false) + :: ,@defs {((lambda (x) (or c1 false x)) false)} + -> ,@defs {(or c1 false false)} + :: ,@defs (or {c1} false false) + -> ,@defs (or {false} false false) + :: ,@defs {(or false false false)} + -> ,@defs {false})) + +(let ([defs `((define (f x) (+ (g x) 10)) (define (g x) (- x 22)))]) + (t 'forward-ref m:upto-int + ,@defs (f 13) + :: ,@defs {(f 13)} + -> ,@defs {(+ (g 13) 10)} + :: ,@defs (+ {(g 13)} 10) + -> ,@defs (+ {(- 13 22)} 10) + -> ,@defs (+ {-9} 10) + :: ,@defs {(+ -9 10)} + -> ,@defs {1})) + +(let ([defs `((define (f x) (+ (g x) 10)) (define (g x) (- x 22)))]) + (t 'forward-ref/lam m:intermediate-lambda + ,@defs (f 13) + :: ,@defs ({f} 13) + -> ,@defs ({(lambda (x) (+ (g x) 10))} 13) + :: ,@defs {((lambda (x) (+ (g x) 10)) 13)} + -> ,@defs {(+ (g 13) 10)} + :: ,@defs (+ ({g} 13) 10) + -> ,@defs (+ ({(lambda (x) (- x 22))} 13) 10) + :: ,@defs (+ {((lambda (x) (- x 22)) 13)} 10) + -> ,@defs (+ {(- 13 22)} 10) + -> ,@defs (+ {-9} 10) + :: ,@defs {(+ -9 10)} + -> ,@defs {1})) + + +;; loops; I should add a mechanism to stop testing after n steps... +#;(let ([defs '((define (f x) (cond (else (f x)))) + (define (g x) x))]) + (t 'pnkfelix m:intermediate-lambda + ,@defs (f (g empty)) + :: ,@defs ({f} (g empty)) + -> ,@defs ({(lambda (x) (cond (else (f x))))} (g empty)) + :: ,@defs ((lambda (x) (cond (else (f x)))) ({g} empty)) + -> ,@defs ((lambda (x) (cond (else (f x)))) ({(lambda (x) x)} empty)))) + +(t 'bad-cons m:upto-int/lam + (cons 1 2) + :: {(cons 1 2)} + -> error: "cons: second argument must be of type , given 1 and 2") + +(t1 'prims + m:beginner "(cons 3 (cons 1 empty)) (list 1 2 3) (define-struct aa (b)) (make-aa 3)" + (let ([defs `((cons 3 (cons 1 empty)))]) + `((before-after (,@defs (hilite (list 1 2 3))) + (,@defs (hilite (cons 1 (cons 2 (cons 3 empty))))))))) + +(t1 'prims/non-beginner + m:bwla-to-int/lam "(cons 3 (cons 1 empty)) (list 1 2 3) (define-struct aa (b)) (make-aa 3)" + `((before-after ((cons 3 (hilite (cons 1 empty)))) ((cons 3 (hilite (list 1))))) + (before-after ((hilite (cons 3 (list 1)))) ((hilite (list 3 1)))))) + + +(t1 'map + m:mz "(map (lambda (x) x) (list 3 4 5))" + `((before-after ((map (lambda (x) x) (hilite (list 3 4 5)))) + ((map (lambda (x) x) (hilite `( 3 4 5))))) + (before-after ((hilite (map (lambda (x) x) `(3 4 5)))) + ((... (hilite 3) ...))) + (before-after (...) + ((... (hilite 4) ...))) + (before-after (...) + ((... (hilite 5) ...))) + (before-after (...) ((hilite `(3 4 5)))))) + +(t1 'quoted-list + m:beginner-wla "'(3 4 5)" + `()) + +(t1 'quoted-list-display + m:bwla-to-int/lam "(define (f x) '((a))) (+ 3 4)" + `((before-after ((define (f x) (list (list 'a))) (hilite (+ 3 4))) + ((define (f x) (list (list 'a))) (hilite 7))) (finished-stepping))) - (t nested-cond2 test-upto-int/lam - (cond [false 3] [else (cond [true 4])]) - :: {(cond (false 3) (else (cond (true 4))))} - -> {(cond (else (cond (true 4))))} - -> {(cond (true 4))} - -> {4}) - (t top-ref test-intermediate-sequence - (define a4 +) a4 - :: (define a4 +) {a4} - -> (define a4 +) {+}) +;;;;;;;;;;;;; +;; +;; QUASIQUOTE +;; +;;;;;;;;;;;;;. - (t top-ref2 test-intermediate-sequence - (define (f123 x) (+ x 13)) f123 - ::) +; note: we currently punt on trying to unwind quasiquote. - (t top-ref3 test-intermediate/lambda-sequence - (define (f123 x) (+ x 13)) f123 - :: (define (f123 x) (+ x 13)) {f123} - -> (define (f123 x) (+ x 13)) {(lambda (x) (+ x 13))}) +(t1 'qq1 + m:beginner-wla "`(3 4 ,(+ 4 5))" + `((before-after ((cons 3 (cons 4 (cons (hilite (+ 4 5)) empty)))) + ((cons 3 (cons 4 (cons (hilite 9) empty))))) + (before-after ((cons 3 (cons 4 (hilite (cons 9 empty))))) + ((cons 3 (cons 4 (hilite (list 9)))))) + (before-after ((cons 3 (hilite (cons 4 (list 9))))) + ((cons 3 (hilite (list 4 9))))) + (before-after ((hilite (cons 3 (list 4 9)))) ((hilite (list 3 4 9)))) + (finished-stepping))) - (let* ([defs1 `((define (a x) (+ x 5)) (define b a))] - [defs2 (append defs1 `((define c a)))]) - (t top-ref4 test-intermediate-sequence - ,@defs1 (define c b) (c 3) - :: ,@defs1 (define c {b}) - -> ,@defs1 (define c {a}) - :: ,@defs2 ({c} 3) - -> ,@defs2 ({a} 3) - :: ,@defs2 {(a 3)} - -> ,@defs2 {(+ 3 5)} - -> ,@defs2 {8})) +(t1 'qq-splice + m:beginner-wla "`(3 ,@(list (+ 3 4) 5) 6)" + `((before-after ((cons 3 (append (list (hilite (+ 3 4)) 5) (cons 6 empty)))) ((cons 3 (append (list (hilite 7) 5) (cons 6 empty))))) + (before-after ((cons 3 (append (list 7 5) (hilite (cons 6 empty))))) ((cons 3 (append (list 7 5) (list 6))))) + (before-after ((cons 3 (hilite (append (list 7 5) (list 6))))) ((cons 3 (hilite (list 7 5 6))))) + (before-after ((hilite (cons 3 (list 7 5 6)))) ((hilite (list 3 7 5 6)))) + (finished-stepping))) - (t define-struct test-upto-int/lam - (define-struct mamba (rhythm tempo)) (mamba-rhythm (make-mamba 24 2)) - :: (define-struct mamba (rhythm tempo)) {(mamba-rhythm (make-mamba 24 2))} - -> (define-struct mamba (rhythm tempo)) {24}) +;;;;;;;;;;;;; +;; +;; LET +;; +;;;;;;;;;;;;; - (let ([def `(define a5 (lambda (a5) (+ a5 13)))]) - (t lam-def test-upto-int - ,def (a5 23) - :: ,def {(a5 23)} - -> ,def {(+ 23 13)} - -> ,def {36})) +(t1 'let1 m:both-intermediates "(let ([a 3]) 4)" + `((before-after ((hilite (let ([a 3]) 4))) ((hilite (define a_0 3)) (hilite 4))) + (finished-stepping))) - (let ([def `(define a5 (lambda (a5) (+ a5 13)))]) - (t lam-def/lam test-intermediate/lambda-sequence - ,def (a5 23) - :: ,def ({a5} 23) - -> ,def ({(lambda (a5) (+ a5 13))} 23) - :: ,def {((lambda (a5) (+ a5 13)) 23)} - -> ,def {(+ 23 13)} - -> ,def {36})) +(t1 'let2 + m:both-intermediates "(let ([a (+ 4 5)] [b (+ 9 20)]) (+ a b))" + `((before-after ((hilite (let ([a (+ 4 5)] [b (+ 9 20)]) (+ a b)))) + ((hilite (define a_0 (+ 4 5))) (hilite (define b_0 (+ 9 20))) (hilite (+ a_0 b_0)))) + (before-after ((define a_0 (hilite (+ 4 5))) (define b_0 (+ 9 20)) (+ a_0 b_0)) + ((define a_0 (hilite 9)) (define b_0 (+ 9 20)) (+ a_0 b_0))) + (before-after ((define a_0 9) (define b_0 (hilite (+ 9 20))) (+ a_0 b_0)) + ((define a_0 9) (define b_0 (hilite 29)) (+ a_0 b_0))) + (before-after ((define a_0 9) (define b_0 29) (+ (hilite a_0) b_0)) + ((define a_0 9) (define b_0 29) (+ (hilite 9) b_0))) + (before-after ((define a_0 9) (define b_0 29) (+ 9 (hilite b_0))) + ((define a_0 9) (define b_0 29) (+ 9 (hilite 29)))) + (before-after ((define a_0 9) (define b_0 29) (hilite (+ 9 29))) + ((define a_0 9) (define b_0 29) (hilite 38))) + (finished-stepping))) - (let ([def `(define a_0 (lambda (x) (+ x 5)))]) - (t lam-let test-intermediate-sequence - (let ([a (lambda (x) (+ x 5))]) (a 6)) - :: {(let ([a (lambda (x) (+ x 5))]) (a 6))} - -> {(define a_0 (lambda (x) (+ x 5)))} {(a_0 6)} - :: ,def {(a_0 6)} - -> ,def {(+ 6 5)} - -> ,def {11})) - - (let ([defs `((define c1 false) - (define (d2 x) (or c1 false x)))]) - (t whocares test-upto-int - ,@defs (d2 false) - :: ,@defs {(d2 false)} - -> ,@defs {(or c1 false false)} - :: ,@defs (or {c1} false false) - -> ,@defs (or {false} false false) - :: ,@defs {(or false false false)} - -> ,@defs {false})) - - (let ([defs `((define c1 false) - (define (d2 x) (or c1 false x)))]) - (t whocares/lam test-intermediate/lambda-sequence - ,@defs (d2 false) - :: ,@defs ({d2} false) - -> ,@defs ({(lambda (x) (or c1 false x))} false) - :: ,@defs {((lambda (x) (or c1 false x)) false)} - -> ,@defs {(or c1 false false)} - :: ,@defs (or {c1} false false) - -> ,@defs (or {false} false false) - :: ,@defs {(or false false false)} - -> ,@defs {false})) - - (let ([defs `((define (f x) (+ (g x) 10)) (define (g x) (- x 22)))]) - (t forward-ref test-upto-int - ,@defs (f 13) - :: ,@defs {(f 13)} - -> ,@defs {(+ (g 13) 10)} - :: ,@defs (+ {(g 13)} 10) - -> ,@defs (+ {(- 13 22)} 10) - -> ,@defs (+ {-9} 10) - :: ,@defs {(+ -9 10)} - -> ,@defs {1})) - - (let ([defs `((define (f x) (+ (g x) 10)) (define (g x) (- x 22)))]) - (t forward-ref/lam test-intermediate/lambda-sequence - ,@defs (f 13) - :: ,@defs ({f} 13) - -> ,@defs ({(lambda (x) (+ (g x) 10))} 13) - :: ,@defs {((lambda (x) (+ (g x) 10)) 13)} - -> ,@defs {(+ (g 13) 10)} - :: ,@defs (+ ({g} 13) 10) - -> ,@defs (+ ({(lambda (x) (- x 22))} 13) 10) - :: ,@defs (+ {((lambda (x) (- x 22)) 13)} 10) - -> ,@defs (+ {(- 13 22)} 10) - -> ,@defs (+ {-9} 10) - :: ,@defs {(+ -9 10)} - -> ,@defs {1})) - - - ;; loops; I should add a mechanism to stop testing after n steps... - #;(let ([defs '((define (f x) (cond (else (f x)))) - (define (g x) x))]) - (t pnkfelix test-intermediate/lambda-sequence - ,@defs (f (g empty)) - :: ,@defs ({f} (g empty)) - -> ,@defs ({(lambda (x) (cond (else (f x))))} (g empty)) - :: ,@defs ((lambda (x) (cond (else (f x)))) ({g} empty)) - -> ,@defs ((lambda (x) (cond (else (f x)))) ({(lambda (x) x)} empty)))) - - (t bad-cons test-upto-int/lam - (cons 1 2) - :: {(cons 1 2)} - -> error: "cons: second argument must be of type , given 1 and 2") - - (t1 prims - (test-beginner-sequence "(cons 3 (cons 1 empty)) (list 1 2 3) (define-struct aa (b)) (make-aa 3)" - (let ([defs `((cons 3 (cons 1 empty)))]) - `((before-after (,@defs (hilite (list 1 2 3))) - (,@defs (hilite (cons 1 (cons 2 (cons 3 empty)))))) - (finished-stepping))))) - - (t1 prims/non-beginner - (test-bwla-to-int/lam "(cons 3 (cons 1 empty)) (list 1 2 3) (define-struct aa (b)) (make-aa 3)" - `((before-after ((cons 3 (hilite (cons 1 empty)))) ((cons 3 (hilite (list 1))))) - (before-after ((hilite (cons 3 (list 1)))) ((hilite (list 3 1)))) - (finished-stepping)))) +(t1 'let-scoping1 + m:intermediate "(let ([a 3]) (let ([a (lambda (x) (+ a x))]) (a 4)))" + (let ([d1 `(define a_0 3)] + [d2 `(define a_1 (lambda (x) (+ a_0 x)))]) + `((before-after ((hilite (let ([a 3]) (let ([a (lambda (x) (+ a x))]) (a 4))))) + ((hilite (define a_0 3)) (hilite (let ([a (lambda (x) (+ a_0 x))]) (a 4))))) + (before-after (,d1 (hilite (let ([a (lambda (x) (+ a_0 x))]) (a 4)))) + (,d1 (hilite (define a_1 (lambda (x) (+ a_0 x)))) (hilite (a_1 4)))) + (before-after (,d1 ,d2 (hilite (a_1 4))) + (,d1 ,d2 (hilite (+ a_0 4)))) + (before-after (,d1 ,d2 (+ (hilite a_0) 4)) + (,d1 ,d2 (+ (hilite 3) 4))) + (before-after (,d1 ,d2 (hilite (+ 3 4))) + (,d1 ,d2 (hilite 7))) + (finished-stepping)))) - (t1 map - (test-mz-sequence "(map (lambda (x) x) (list 3 4 5))" - `((before-after ((map (lambda (x) x) (hilite (list 3 4 5)))) - ((map (lambda (x) x) (hilite `( 3 4 5))))) - (before-after ((hilite (map (lambda (x) x) `(3 4 5)))) - ((... (hilite 3) ...))) - (before-after (...) - ((... (hilite 4) ...))) - (before-after (...) - ((... (hilite 5) ...))) - (before-after (...) ((hilite `(3 4 5)))) - (finished-stepping)))) +(t1 'let-scoping2 + m:intermediate-lambda "(let ([a 3]) (let ([a (lambda (x) (+ a x))]) (a 4)))" + (let* ([d1 `(define a_0 3)] + [defs `(,d1 (define a_1 (lambda (x) (+ a_0 x))))]) + `((before-after ((hilite (let ([a 3]) (let ([a (lambda (x) (+ a x))]) (a 4))))) + ((hilite (define a_0 3)) (hilite (let ([a (lambda (x) (+ a_0 x))]) (a 4))))) + (before-after (,d1 (hilite (let ([a (lambda (x) (+ a_0 x))]) (a 4)))) + (,d1 (hilite (define a_1 (lambda (x) (+ a_0 x)))) (hilite (a_1 4)))) + (before-after (,@defs ((hilite a_1) 4)) + (,@defs ((hilite (lambda (x) (+ a_0 x))) 4))) + (before-after (,@defs (hilite ((lambda (x) (+ a_0 x)) 4))) (,@defs (hilite (+ a_0 4)))) + (before-after (,@defs (+ (hilite a_0) 4)) (,@defs (+ (hilite 3) 4))) + (before-after (,@defs (hilite (+ 3 4))) (,@defs (hilite 7))) + (finished-stepping)))) - (t1 quoted-list - (test-beginner-wla-sequence "'(3 4 5)" - `((finished-stepping)))) +(t1 'let-scoping3 + m:intermediate "(define a12 3) (define c12 19) (let ([a12 13] [b12 a12]) (+ b12 a12 c12))" + (let* ([defs1 `((define a12 3) (define c12 19))] + [defs2 `(,@defs1 (define a12_0 13))] + [defs3 `(,@defs2 (define b12_0 3))]) + `((before-after (,@defs1 (hilite (let ([a12 13] [b12 a12]) (+ b12 a12 c12)))) + (,@defs1 (hilite (define a12_0 13)) (hilite (define b12_0 a12)) (hilite (+ b12_0 a12_0 c12)))) + (before-after (,@defs2 (define b12_0 (hilite a12)) (+ b12_0 a12_0 c12)) + (,@defs2 (define b12_0 (hilite 3)) (+ b12_0 a12_0 c12))) + (before-after (,@defs3 (+ (hilite b12_0) a12_0 c12)) + (,@defs3 (+ (hilite 3) a12_0 c12))) + (before-after (,@defs3 (+ 3 (hilite a12_0) c12)) + (,@defs3 (+ 3 (hilite 13) c12))) + (before-after (,@defs3 (+ 3 13 (hilite c12))) + (,@defs3 (+ 3 13 (hilite 19)))) + (before-after (,@defs3 (hilite (+ 3 13 19))) + (,@defs3 (hilite 35))) + (finished-stepping)))) - (t1 quoted-list-display - (test-bwla-to-int/lam "(define (f x) '((a))) (+ 3 4)" - `((before-after ((define (f x) (list (list 'a))) (hilite (+ 3 4))) - ((define (f x) (list (list 'a))) (hilite 7))) - (finished-stepping)))) +(t1 'let-lifting1 + m:intermediate "(let ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9)" + `((before-after ((hilite (let ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9))) + ((hilite (define a_0 (lambda (x) (+ x 14)))) (hilite (define b_0 (+ 3 4))) (hilite 9))) + (before-after ((define a_0 (lambda (x) (+ x 14))) (define b_0 (hilite (+ 3 4))) 9) + ((define a_0 (lambda (x) (+ x 14))) (define b_0 (hilite 7)) 9)) + (finished-stepping))) +(t1 'let-deriv + m:intermediate "(define (f g) (let ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)) (define gprime (f cos))" + (let ([defs `((define (f g) (let ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)))]) + `((before-after (,@defs (define gprime (hilite (f cos)))) + (,@defs (define gprime (hilite (let ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp))))) + (before-after (,@defs (define gprime (hilite (let ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp)))) + (,@defs (hilite (define gp_0 (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001)))) (define gprime (hilite gp_0)))) + (finished-stepping)))) - ;;;;;;;;;;;;; - ;; - ;; QUASIQUOTE - ;; - ;;;;;;;;;;;;;. +(t1 'let-assigned + m:intermediate "(define a (let ([f (lambda (x) (+ x 13))]) f))" + `((before-after ((define a (hilite (let ([f (lambda (x) (+ x 13))]) f)))) + ((hilite (define f_0 (lambda (x) (+ x 13)))) (define a (hilite f_0)))) + (finished-stepping))) - ; note: we currently punt on trying to unwind quasiquote. +(t1 'let-assigned/lam + m:intermediate-lambda "(define a (let ([f (lambda (x) (+ x 13))]) f))" + `((before-after ((define a (hilite (let ([f (lambda (x) (+ x 13))]) f)))) + ((hilite (define f_0 (lambda (x) (+ x 13)))) (define a (hilite f_0)))) + (before-after ((define f_0 (lambda (x) (+ x 13))) (define a (hilite f_0))) + ((define f_0 (lambda (x) (+ x 13))) (define a (hilite (lambda (x) (+ x 13)))))) + (finished-stepping))) - (t1 qq1 - (test-beginner-wla-sequence "`(3 4 ,(+ 4 5))" - `((before-after ((cons 3 (cons 4 (cons (hilite (+ 4 5)) empty)))) - ((cons 3 (cons 4 (cons (hilite 9) empty))))) - (before-after ((cons 3 (cons 4 (hilite (cons 9 empty))))) - ((cons 3 (cons 4 (hilite (list 9)))))) - (before-after ((cons 3 (hilite (cons 4 (list 9))))) - ((cons 3 (hilite (list 4 9))))) - (before-after ((hilite (cons 3 (list 4 9)))) ((hilite (list 3 4 9)))) - (finished-stepping)))) +;;;;;;;;;;;;; +;; +;; LET* +;; +;;;;;;;;;;;;; - (t1 qq-splice - (test-beginner-wla-sequence "`(3 ,@(list (+ 3 4) 5) 6)" - `((before-after ((cons 3 (append (list (hilite (+ 3 4)) 5) (cons 6 empty)))) ((cons 3 (append (list (hilite 7) 5) (cons 6 empty))))) - (before-after ((cons 3 (append (list 7 5) (hilite (cons 6 empty))))) ((cons 3 (append (list 7 5) (list 6))))) - (before-after ((cons 3 (hilite (append (list 7 5) (list 6))))) ((cons 3 (hilite (list 7 5 6))))) - (before-after ((hilite (cons 3 (list 7 5 6)))) ((hilite (list 3 7 5 6)))) - (finished-stepping)))) +(t1 'let*-scoping1 + m:both-intermediates "(define a 3) (define c 19) (let* ([a 13] [b a]) (+ b a c))" + (let* ([defs1 `((define a 3) (define c 19))] + [defs2 (append defs1 `((define a_0 13)))] + [defs3 (append defs2 `((define b_1 13)))]) + `((before-after (,@defs1 (hilite (let* ([a 13] [b a]) (+ b a c)))) + (,@defs1 (hilite (define a_0 13)) (hilite (let* ([b a_0]) (+ b a_0 c))))) + (before-after (,@defs2 (hilite (let* ([b a_0]) (+ b a_0 c)))) + (,@defs2 (hilite (define b_1 a_0)) (hilite (+ b_1 a_0 c)))) + (before-after (,@defs2 (define b_1 (hilite a_0)) (+ b_1 a_0 c)) + (,@defs2 (define b_1 (hilite 13)) (+ b_1 a_0 c))) + (before-after (,@defs3 (+ (hilite b_1) a_0 c)) + (,@defs3 (+ (hilite 13) a_0 c))) + (before-after (,@defs3 (+ 13 (hilite a_0) c)) + (,@defs3 (+ 13 (hilite 13) c))) + (before-after (,@defs3 (+ 13 13 (hilite c))) + (,@defs3 (+ 13 13 (hilite 19)))) + (before-after (,@defs3 (hilite (+ 13 13 19))) + (,@defs3 (hilite 45))) + (finished-stepping)))) - ;;;;;;;;;;;;; - ;; - ;; LET - ;; - ;;;;;;;;;;;;; +(t1 'let*-lifting1 + m:intermediate "(let* ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9)" + (let ([defs `((define a_0 (lambda (x) (+ x 14))))]) + `((before-after ((hilite (let* ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9))) + ((hilite (define a_0 (lambda (x) (+ x 14)))) (hilite (let* ([b (+ 3 4)]) 9)))) + (before-after (,@defs (hilite (let* ([b (+ 3 4)]) 9))) + (,@defs (hilite (define b_1 (+ 3 4))) (hilite 9))) + (before-after (,@defs (define b_1 (hilite (+ 3 4))) 9) + (,@defs (define b_1 (hilite 7)) 9)) + (finished-stepping)))) - (t1 let1 (test-both-ints "(let ([a 3]) 4)" - `((before-after ((hilite (let ([a 3]) 4))) ((hilite (define a_0 3)) (hilite 4))) - (finished-stepping)))) +(t1 'let*-deriv + m:intermediate "(define (f g) (let* ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)) (define gprime (f cos))" + (let ([defs `((define (f g) (let* ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)))]) + `((before-after (,@defs (define gprime (hilite (f cos)))) + (,@defs (define gprime (hilite (let* ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp))))) + (before-after (,@defs (define gprime (hilite (let* ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp)))) + (,@defs (hilite (define gp_0 (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001)))) (define gprime (hilite gp_0)))) + (finished-stepping)))) - (t1 let2 - (test-both-ints "(let ([a (+ 4 5)] [b (+ 9 20)]) (+ a b))" - `((before-after ((hilite (let ([a (+ 4 5)] [b (+ 9 20)]) (+ a b)))) - ((hilite (define a_0 (+ 4 5))) (hilite (define b_0 (+ 9 20))) (hilite (+ a_0 b_0)))) - (before-after ((define a_0 (hilite (+ 4 5))) (define b_0 (+ 9 20)) (+ a_0 b_0)) - ((define a_0 (hilite 9)) (define b_0 (+ 9 20)) (+ a_0 b_0))) - (before-after ((define a_0 9) (define b_0 (hilite (+ 9 20))) (+ a_0 b_0)) - ((define a_0 9) (define b_0 (hilite 29)) (+ a_0 b_0))) - (before-after ((define a_0 9) (define b_0 29) (+ (hilite a_0) b_0)) - ((define a_0 9) (define b_0 29) (+ (hilite 9) b_0))) - (before-after ((define a_0 9) (define b_0 29) (+ 9 (hilite b_0))) - ((define a_0 9) (define b_0 29) (+ 9 (hilite 29)))) - (before-after ((define a_0 9) (define b_0 29) (hilite (+ 9 29))) - ((define a_0 9) (define b_0 29) (hilite 38))) - (finished-stepping)))) +(t1 'let/let* + m:both-intermediates "(let* ([a 9]) (let ([b 6]) a))" + `((before-after ((hilite (let* ([a 9]) (let ([b 6]) a)))) ((hilite (define a_0 9)) (hilite (let ([b 6]) a_0)))) + (before-after ((define a_0 9) (hilite (let ([b 6]) a_0))) + ((define a_0 9) (hilite (define b_1 6)) (hilite a_0))) + (before-after ((define a_0 9) (define b_1 6) (hilite a_0)) + ((define a_0 9) (define b_1 6) (hilite 9))) + (finished-stepping))) - (t1 let-scoping1 - (test-intermediate-sequence "(let ([a 3]) (let ([a (lambda (x) (+ a x))]) (a 4)))" - (let ([d1 `(define a_0 3)] - [d2 `(define a_1 (lambda (x) (+ a_0 x)))]) - `((before-after ((hilite (let ([a 3]) (let ([a (lambda (x) (+ a x))]) (a 4))))) - ((hilite (define a_0 3)) (hilite (let ([a (lambda (x) (+ a_0 x))]) (a 4))))) - (before-after (,d1 (hilite (let ([a (lambda (x) (+ a_0 x))]) (a 4)))) - (,d1 (hilite (define a_1 (lambda (x) (+ a_0 x)))) (hilite (a_1 4)))) - (before-after (,d1 ,d2 (hilite (a_1 4))) - (,d1 ,d2 (hilite (+ a_0 4)))) - (before-after (,d1 ,d2 (+ (hilite a_0) 4)) - (,d1 ,d2 (+ (hilite 3) 4))) - (before-after (,d1 ,d2 (hilite (+ 3 4))) - (,d1 ,d2 (hilite 7))) - (finished-stepping))))) +;;;;;;;;;;;;; +;; +;; LETREC +;; +;;;;;;;;;;;;; - (t1 let-scoping2 - (test-intermediate/lambda-sequence "(let ([a 3]) (let ([a (lambda (x) (+ a x))]) (a 4)))" - (let* ([d1 `(define a_0 3)] - [defs `(,d1 (define a_1 (lambda (x) (+ a_0 x))))]) - `((before-after ((hilite (let ([a 3]) (let ([a (lambda (x) (+ a x))]) (a 4))))) - ((hilite (define a_0 3)) (hilite (let ([a (lambda (x) (+ a_0 x))]) (a 4))))) - (before-after (,d1 (hilite (let ([a (lambda (x) (+ a_0 x))]) (a 4)))) - (,d1 (hilite (define a_1 (lambda (x) (+ a_0 x)))) (hilite (a_1 4)))) - (before-after (,@defs ((hilite a_1) 4)) - (,@defs ((hilite (lambda (x) (+ a_0 x))) 4))) - (before-after (,@defs (hilite ((lambda (x) (+ a_0 x)) 4))) (,@defs (hilite (+ a_0 4)))) - (before-after (,@defs (+ (hilite a_0) 4)) (,@defs (+ (hilite 3) 4))) - (before-after (,@defs (hilite (+ 3 4))) (,@defs (hilite 7))) - (finished-stepping))))) +(t1 'letrec1 + m:intermediate "(define a 3) (define c 19) (letrec ([a 13] [b a]) (+ b a c))" + (let* ([defs1 `((define a 3) (define c 19))] + [defs2 (append defs1 `((define a_0 13)))] + [defs3 (append defs2 `((define b_0 13)))]) + `((before-after (,@defs1 (hilite (letrec ([a 13] [b a]) (+ b a c)))) + (,@defs1 (hilite (define a_0 13)) (hilite (define b_0 a_0)) (hilite (+ b_0 a_0 c)))) + (before-after (,@defs2 (define b_0 (hilite a_0)) (+ b_0 a_0 c)) + (,@defs2 (define b_0 (hilite 13)) (+ b_0 a_0 c))) + (before-after (,@defs3 (+ (hilite b_0) a_0 c)) + (,@defs3 (+ (hilite 13) a_0 c))) + (before-after (,@defs3 (+ 13 (hilite a_0) c)) + (,@defs3 (+ 13 (hilite 13) c))) + (before-after (,@defs3 (+ 13 13 (hilite c))) + (,@defs3 (+ 13 13 (hilite 19)))) + (before-after (,@defs3 (hilite (+ 13 13 19))) + (,@defs3 (hilite 45))) + (finished-stepping)))) - (t1 let-scoping3 - (test-intermediate-sequence "(define a12 3) (define c12 19) (let ([a12 13] [b12 a12]) (+ b12 a12 c12))" - (let* ([defs1 `((define a12 3) (define c12 19))] - [defs2 `(,@defs1 (define a12_0 13))] - [defs3 `(,@defs2 (define b12_0 3))]) - `((before-after (,@defs1 (hilite (let ([a12 13] [b12 a12]) (+ b12 a12 c12)))) - (,@defs1 (hilite (define a12_0 13)) (hilite (define b12_0 a12)) (hilite (+ b12_0 a12_0 c12)))) - (before-after (,@defs2 (define b12_0 (hilite a12)) (+ b12_0 a12_0 c12)) - (,@defs2 (define b12_0 (hilite 3)) (+ b12_0 a12_0 c12))) - (before-after (,@defs3 (+ (hilite b12_0) a12_0 c12)) - (,@defs3 (+ (hilite 3) a12_0 c12))) - (before-after (,@defs3 (+ 3 (hilite a12_0) c12)) - (,@defs3 (+ 3 (hilite 13) c12))) - (before-after (,@defs3 (+ 3 13 (hilite c12))) - (,@defs3 (+ 3 13 (hilite 19)))) - (before-after (,@defs3 (hilite (+ 3 13 19))) - (,@defs3 (hilite 35))) - (finished-stepping))))) + (t1 'letrec2 + m:intermediate "(letrec ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9)" + `((before-after ((hilite (letrec ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9))) + ((hilite (define a_0 (lambda (x) (+ x 14)))) (hilite (define b_0 (+ 3 4))) (hilite 9))) + (before-after ((define a_0 (lambda (x) (+ x 14))) (define b_0 (hilite (+ 3 4))) 9) + ((define a_0 (lambda (x) (+ x 14))) (define b_0 (hilite 7)) 9)) + (finished-stepping))) - (t1 let-lifting1 - (test-intermediate-sequence "(let ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9)" - `((before-after ((hilite (let ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9))) - ((hilite (define a_0 (lambda (x) (+ x 14)))) (hilite (define b_0 (+ 3 4))) (hilite 9))) - (before-after ((define a_0 (lambda (x) (+ x 14))) (define b_0 (hilite (+ 3 4))) 9) - ((define a_0 (lambda (x) (+ x 14))) (define b_0 (hilite 7)) 9)) - (finished-stepping)))) - - (t1 let-deriv - (test-intermediate-sequence "(define (f g) (let ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)) (define gprime (f cos))" - (let ([defs `((define (f g) (let ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)))]) - `((before-after (,@defs (define gprime (hilite (f cos)))) - (,@defs (define gprime (hilite (let ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp))))) - (before-after (,@defs (define gprime (hilite (let ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp)))) - (,@defs (hilite (define gp_0 (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001)))) (define gprime (hilite gp_0)))) - (finished-stepping))))) - - (t1 let-assigned - (test-intermediate-sequence "(define a (let ([f (lambda (x) (+ x 13))]) f))" - `((before-after ((define a (hilite (let ([f (lambda (x) (+ x 13))]) f)))) - ((hilite (define f_0 (lambda (x) (+ x 13)))) (define a (hilite f_0)))) - (finished-stepping)))) - - (t1 let-assigned/lam - (test-intermediate/lambda-sequence "(define a (let ([f (lambda (x) (+ x 13))]) f))" - `((before-after ((define a (hilite (let ([f (lambda (x) (+ x 13))]) f)))) - ((hilite (define f_0 (lambda (x) (+ x 13)))) (define a (hilite f_0)))) - (before-after ((define f_0 (lambda (x) (+ x 13))) (define a (hilite f_0))) - ((define f_0 (lambda (x) (+ x 13))) (define a (hilite (lambda (x) (+ x 13)))))) - (finished-stepping)))) - - ;;;;;;;;;;;;; - ;; - ;; LET* - ;; - ;;;;;;;;;;;;; - - (t1 let*-scoping1 - (test-both-ints "(define a 3) (define c 19) (let* ([a 13] [b a]) (+ b a c))" - (let* ([defs1 `((define a 3) (define c 19))] - [defs2 (append defs1 `((define a_0 13)))] - [defs3 (append defs2 `((define b_1 13)))]) - `((before-after (,@defs1 (hilite (let* ([a 13] [b a]) (+ b a c)))) - (,@defs1 (hilite (define a_0 13)) (hilite (let* ([b a_0]) (+ b a_0 c))))) - (before-after (,@defs2 (hilite (let* ([b a_0]) (+ b a_0 c)))) - (,@defs2 (hilite (define b_1 a_0)) (hilite (+ b_1 a_0 c)))) - (before-after (,@defs2 (define b_1 (hilite a_0)) (+ b_1 a_0 c)) - (,@defs2 (define b_1 (hilite 13)) (+ b_1 a_0 c))) - (before-after (,@defs3 (+ (hilite b_1) a_0 c)) - (,@defs3 (+ (hilite 13) a_0 c))) - (before-after (,@defs3 (+ 13 (hilite a_0) c)) - (,@defs3 (+ 13 (hilite 13) c))) - (before-after (,@defs3 (+ 13 13 (hilite c))) - (,@defs3 (+ 13 13 (hilite 19)))) - (before-after (,@defs3 (hilite (+ 13 13 19))) - (,@defs3 (hilite 45))) - (finished-stepping))))) - - (t1 let*-lifting1 - (test-intermediate-sequence "(let* ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9)" - (let ([defs `((define a_0 (lambda (x) (+ x 14))))]) - `((before-after ((hilite (let* ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9))) - ((hilite (define a_0 (lambda (x) (+ x 14)))) (hilite (let* ([b (+ 3 4)]) 9)))) - (before-after (,@defs (hilite (let* ([b (+ 3 4)]) 9))) - (,@defs (hilite (define b_1 (+ 3 4))) (hilite 9))) - (before-after (,@defs (define b_1 (hilite (+ 3 4))) 9) - (,@defs (define b_1 (hilite 7)) 9)) - (finished-stepping))))) - - (t1 let*-deriv - (test-intermediate-sequence "(define (f g) (let* ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)) (define gprime (f cos))" - (let ([defs `((define (f g) (let* ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)))]) - `((before-after (,@defs (define gprime (hilite (f cos)))) - (,@defs (define gprime (hilite (let* ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp))))) - (before-after (,@defs (define gprime (hilite (let* ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp)))) - (,@defs (hilite (define gp_0 (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001)))) (define gprime (hilite gp_0)))) - (finished-stepping))))) - - (t1 let/let* - (test-both-ints "(let* ([a 9]) (let ([b 6]) a))" - `((before-after ((hilite (let* ([a 9]) (let ([b 6]) a)))) ((hilite (define a_0 9)) (hilite (let ([b 6]) a_0)))) - (before-after ((define a_0 9) (hilite (let ([b 6]) a_0))) - ((define a_0 9) (hilite (define b_1 6)) (hilite a_0))) - (before-after ((define a_0 9) (define b_1 6) (hilite a_0)) - ((define a_0 9) (define b_1 6) (hilite 9))) - (finished-stepping)))) - - ;;;;;;;;;;;;; - ;; - ;; LETREC - ;; - ;;;;;;;;;;;;; - - (t1 letrec1 - (test-intermediate-sequence "(define a 3) (define c 19) (letrec ([a 13] [b a]) (+ b a c))" - (let* ([defs1 `((define a 3) (define c 19))] - [defs2 (append defs1 `((define a_0 13)))] - [defs3 (append defs2 `((define b_0 13)))]) - `((before-after (,@defs1 (hilite (letrec ([a 13] [b a]) (+ b a c)))) - (,@defs1 (hilite (define a_0 13)) (hilite (define b_0 a_0)) (hilite (+ b_0 a_0 c)))) - (before-after (,@defs2 (define b_0 (hilite a_0)) (+ b_0 a_0 c)) - (,@defs2 (define b_0 (hilite 13)) (+ b_0 a_0 c))) - (before-after (,@defs3 (+ (hilite b_0) a_0 c)) - (,@defs3 (+ (hilite 13) a_0 c))) - (before-after (,@defs3 (+ 13 (hilite a_0) c)) - (,@defs3 (+ 13 (hilite 13) c))) - (before-after (,@defs3 (+ 13 13 (hilite c))) - (,@defs3 (+ 13 13 (hilite 19)))) - (before-after (,@defs3 (hilite (+ 13 13 19))) - (,@defs3 (hilite 45))) - (finished-stepping))))) - - (t1 letrec2 - (test-intermediate-sequence "(letrec ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9)" - `((before-after ((hilite (letrec ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9))) - ((hilite (define a_0 (lambda (x) (+ x 14)))) (hilite (define b_0 (+ 3 4))) (hilite 9))) - (before-after ((define a_0 (lambda (x) (+ x 14))) (define b_0 (hilite (+ 3 4))) 9) - ((define a_0 (lambda (x) (+ x 14))) (define b_0 (hilite 7)) 9)) - (finished-stepping)))) - - (t1 letrec3 - (test-intermediate-sequence "(define (f g) (letrec ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)) (define gprime (f cos))" - (let ([defs `((define (f g) (letrec ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)))]) - `((before-after (,@defs (define gprime (hilite (f cos)))) - (,@defs (define gprime (hilite (letrec ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp))))) - (before-after (,@defs (define gprime (hilite (letrec ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp)))) - (,@defs (hilite (define gp_0 (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001)))) (define gprime (hilite gp_0)))) - (finished-stepping))))) + (t1 'letrec3 + m:intermediate "(define (f g) (letrec ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)) (define gprime (f cos))" + (let ([defs `((define (f g) (letrec ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)))]) + `((before-after (,@defs (define gprime (hilite (f cos)))) + (,@defs (define gprime (hilite (letrec ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp))))) + (before-after (,@defs (define gprime (hilite (letrec ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp)))) + (,@defs (hilite (define gp_0 (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001)))) (define gprime (hilite gp_0)))) + (finished-stepping)))) ;;;;;;;;;;;;; ;; ;; RECUR @@ -993,45 +721,45 @@ ;; just the applied loop identifier. This is hard to fix because we have an application which is initially hidden, but then later ;; not hidden. Fixing this involves parameterizing the unwind by what kind of break it was. Yuck! So we just fudge the test case. - (t1 recur - (test-advanced-sequence "(define (countdown n) (recur loop ([n n]) (if (= n 0) 13 (loop (- n 1))))) (countdown 2)" - (let* ([defs1 `((define (countdown n) (recur loop ([n n]) (if (= n 0) 13 (loop (- n 1))))))] - [defs2 (append defs1 `((define (loop_0 n) (if (= n 0) 13 (loop_0 (- n 1))))))]) - `((before-after (,@defs1 ((hilite countdown) 2)) - (,@defs1 ((hilite (lambda (n) (recur loop ([n n]) (if (= n 0) 13 (loop (- n 1)))))) 2))) - (before-after (,@defs1 (hilite ((lambda (n) (recur loop ([n n]) (if (= n 0) 13 (loop (- n 1))))) 2))) - (,@defs1 (hilite (recur loop ([n 2]) (if (= n 0) 13 (loop (- n 1))))))) - (before-after (,@defs1 (hilite (recur loop ([n 2]) (if (= n 0) 13 (loop (- n 1)))))) - (,@defs1 (hilite (define (loop_0 n) (if (= n 0) 13 (loop_0 (- n 1))))) ((hilite loop_0) 2))) - (before-after (,@defs2 ((hilite loop_0) 2)) - (,@defs2 ((hilite (lambda (n) (if (= n 0) 13 (loop_0 (- n 1))))) 2))) - (before-after (,@defs2 (hilite ((lambda (n) (if (= n 0) 13 (loop_0 (- n 1)))) 2))) - (,@defs2 (hilite (if (= 2 0) 13 (loop_0 (- 2 1)))))) - (before-after (,@defs2 (if (hilite (= 2 0)) 13 (loop_0 (- 2 1)))) - (,@defs2 (if (hilite false) 13 (loop_0 (- 2 1))))) - (before-after (,@defs2 (hilite (if false 13 (loop_0 (- 2 1))))) - (,@defs2 (hilite (loop_0 (- 2 1))))) - (before-after (,@defs2 ((hilite loop_0) (- 2 1))) - (,@defs2 ((hilite (lambda (n) (if (= n 0) 13 (loop_0 (- n 1))))) (- 2 1)))) - (before-after (,@defs2 ((lambda (n) (if (= n 0) 13 (loop_0 (- n 1)))) (hilite (- 2 1)))) - (,@defs2 ((lambda (n) (if (= n 0) 13 (loop_0 (- n 1)))) (hilite 1)))) - (before-after (,@defs2 (hilite ((lambda (n) (if (= n 0) 13 (loop_0 (- n 1)))) 1))) - (,@defs2 (hilite (if (= 1 0) 13 (loop_0 (- 1 1)))))) - (before-after (,@defs2 (if (hilite (= 1 0)) 13 (loop_0 (- 1 1)))) - (,@defs2 (if (hilite false) 13 (loop_0 (- 1 1))))) - (before-after (,@defs2 (hilite (if false 13 (loop_0 (- 1 1))))) - (,@defs2 (hilite (loop_0 (- 1 1))))) - (before-after (,@defs2 ((hilite loop_0) (- 1 1))) - (,@defs2 ((hilite (lambda (n) (if (= n 0) 13 (loop_0 (- n 1))))) (- 1 1)))) - (before-after (,@defs2 ((lambda (n) (if (= n 0) 13 (loop_0 (- n 1)))) (hilite (- 1 1)))) - (,@defs2 ((lambda (n) (if (= n 0) 13 (loop_0 (- n 1)))) (hilite 0)))) - (before-after (,@defs2 (hilite ((lambda (n) (if (= n 0) 13 (loop_0 (- n 1)))) 0))) - (,@defs2 (hilite (if (= 0 0) 13 (loop_0 (- 0 1)))))) - (before-after (,@defs2 (if (hilite (= 0 0)) 13 (loop_0 (- 0 1)))) - (,@defs2 (if (hilite true) 13 (loop_0 (- 0 1))))) - (before-after (,@defs2 (hilite (if true 13 (loop_0 (- 0 1))))) - (,@defs2 (hilite 13))) - (finished-stepping))))) + (t1 'recur + m:advanced "(define (countdown n) (recur loop ([n n]) (if (= n 0) 13 (loop (- n 1))))) (countdown 2)" + (let* ([defs1 `((define (countdown n) (recur loop ([n n]) (if (= n 0) 13 (loop (- n 1))))))] + [defs2 (append defs1 `((define (loop_0 n) (if (= n 0) 13 (loop_0 (- n 1))))))]) + `((before-after (,@defs1 ((hilite countdown) 2)) + (,@defs1 ((hilite (lambda (n) (recur loop ([n n]) (if (= n 0) 13 (loop (- n 1)))))) 2))) + (before-after (,@defs1 (hilite ((lambda (n) (recur loop ([n n]) (if (= n 0) 13 (loop (- n 1))))) 2))) + (,@defs1 (hilite (recur loop ([n 2]) (if (= n 0) 13 (loop (- n 1))))))) + (before-after (,@defs1 (hilite (recur loop ([n 2]) (if (= n 0) 13 (loop (- n 1)))))) + (,@defs1 (hilite (define (loop_0 n) (if (= n 0) 13 (loop_0 (- n 1))))) ((hilite loop_0) 2))) + (before-after (,@defs2 ((hilite loop_0) 2)) + (,@defs2 ((hilite (lambda (n) (if (= n 0) 13 (loop_0 (- n 1))))) 2))) + (before-after (,@defs2 (hilite ((lambda (n) (if (= n 0) 13 (loop_0 (- n 1)))) 2))) + (,@defs2 (hilite (if (= 2 0) 13 (loop_0 (- 2 1)))))) + (before-after (,@defs2 (if (hilite (= 2 0)) 13 (loop_0 (- 2 1)))) + (,@defs2 (if (hilite false) 13 (loop_0 (- 2 1))))) + (before-after (,@defs2 (hilite (if false 13 (loop_0 (- 2 1))))) + (,@defs2 (hilite (loop_0 (- 2 1))))) + (before-after (,@defs2 ((hilite loop_0) (- 2 1))) + (,@defs2 ((hilite (lambda (n) (if (= n 0) 13 (loop_0 (- n 1))))) (- 2 1)))) + (before-after (,@defs2 ((lambda (n) (if (= n 0) 13 (loop_0 (- n 1)))) (hilite (- 2 1)))) + (,@defs2 ((lambda (n) (if (= n 0) 13 (loop_0 (- n 1)))) (hilite 1)))) + (before-after (,@defs2 (hilite ((lambda (n) (if (= n 0) 13 (loop_0 (- n 1)))) 1))) + (,@defs2 (hilite (if (= 1 0) 13 (loop_0 (- 1 1)))))) + (before-after (,@defs2 (if (hilite (= 1 0)) 13 (loop_0 (- 1 1)))) + (,@defs2 (if (hilite false) 13 (loop_0 (- 1 1))))) + (before-after (,@defs2 (hilite (if false 13 (loop_0 (- 1 1))))) + (,@defs2 (hilite (loop_0 (- 1 1))))) + (before-after (,@defs2 ((hilite loop_0) (- 1 1))) + (,@defs2 ((hilite (lambda (n) (if (= n 0) 13 (loop_0 (- n 1))))) (- 1 1)))) + (before-after (,@defs2 ((lambda (n) (if (= n 0) 13 (loop_0 (- n 1)))) (hilite (- 1 1)))) + (,@defs2 ((lambda (n) (if (= n 0) 13 (loop_0 (- n 1)))) (hilite 0)))) + (before-after (,@defs2 (hilite ((lambda (n) (if (= n 0) 13 (loop_0 (- n 1)))) 0))) + (,@defs2 (hilite (if (= 0 0) 13 (loop_0 (- 0 1)))))) + (before-after (,@defs2 (if (hilite (= 0 0)) 13 (loop_0 (- 0 1)))) + (,@defs2 (if (hilite true) 13 (loop_0 (- 0 1))))) + (before-after (,@defs2 (hilite (if true 13 (loop_0 (- 0 1))))) + (,@defs2 (hilite 13))) + (finished-stepping)))) ;;;;;;;;;;;;; ;; @@ -1040,166 +768,166 @@ ;;;;;;;;;;;;; - (t1 empty-local - (test-both-ints "(local () (+ 3 4))" - `((before-after ((hilite (local () (+ 3 4)))) ((hilite (+ 3 4)))) - (before-after ((hilite (+ 3 4))) ((hilite 7))) - (finished-stepping)))) + (t1 'empty-local + m:both-intermediates "(local () (+ 3 4))" + `((before-after ((hilite (local () (+ 3 4)))) ((hilite (+ 3 4)))) + (before-after ((hilite (+ 3 4))) ((hilite 7))) + (finished-stepping))) - (t1 local1 - (test-both-ints "(local ((define a 3) (define b 8)) 4)" - `((before-after ((hilite (local ((define a 3) (define b 8)) 4))) - ((hilite (define a_0 3)) (hilite (define b_0 8)) (hilite 4))) - (finished-stepping)))) + (t1 'local1 + m:both-intermediates "(local ((define a 3) (define b 8)) 4)" + `((before-after ((hilite (local ((define a 3) (define b 8)) 4))) + ((hilite (define a_0 3)) (hilite (define b_0 8)) (hilite 4))) + (finished-stepping))) - (t1 local2 - (test-intermediate-sequence "(local ((define (a x) (+ x 9))) (a 6))" - (let ([defs `((define (a_0 x) (+ x 9)))]) - `((before-after ((hilite (local ((define (a x) (+ x 9))) (a 6)))) - ((hilite (define (a_0 x) (+ x 9))) (hilite (a_0 6)))) - (before-after (,@defs (hilite (a_0 6))) - (,@defs (hilite (+ 6 9)))) - (before-after (,@defs (hilite (+ 6 9))) - (,@defs (hilite 15))) - (finished-stepping))))) + (t1 'local2 + m:intermediate "(local ((define (a x) (+ x 9))) (a 6))" + (let ([defs `((define (a_0 x) (+ x 9)))]) + `((before-after ((hilite (local ((define (a x) (+ x 9))) (a 6)))) + ((hilite (define (a_0 x) (+ x 9))) (hilite (a_0 6)))) + (before-after (,@defs (hilite (a_0 6))) + (,@defs (hilite (+ 6 9)))) + (before-after (,@defs (hilite (+ 6 9))) + (,@defs (hilite 15))) + (finished-stepping)))) - (t1 local3 - (test-intermediate/lambda-sequence "(local ((define (a x) (+ x 9))) (a 6))" - (let ([defs `((define (a_0 x) (+ x 9)))]) - `((before-after ((hilite (local ((define (a x) (+ x 9))) (a 6)))) - ((hilite (define (a_0 x) (+ x 9))) (hilite (a_0 6)))) - (before-after (,@defs ((hilite a_0) 6)) - (,@defs ((hilite (lambda (x) (+ x 9))) 6))) - (before-after (,@defs (hilite ((lambda (x) (+ x 9)) 6))) - (,@defs (hilite (+ 6 9)))) - (before-after (,@defs (hilite (+ 6 9))) - (,@defs (hilite 15))) - (finished-stepping))))) + (t1 'local3 + m:intermediate-lambda "(local ((define (a x) (+ x 9))) (a 6))" + (let ([defs `((define (a_0 x) (+ x 9)))]) + `((before-after ((hilite (local ((define (a x) (+ x 9))) (a 6)))) + ((hilite (define (a_0 x) (+ x 9))) (hilite (a_0 6)))) + (before-after (,@defs ((hilite a_0) 6)) + (,@defs ((hilite (lambda (x) (+ x 9))) 6))) + (before-after (,@defs (hilite ((lambda (x) (+ x 9)) 6))) + (,@defs (hilite (+ 6 9)))) + (before-after (,@defs (hilite (+ 6 9))) + (,@defs (hilite 15))) + (finished-stepping)))) - (t1 local4 - (test-intermediate-sequence "(local ((define (a x) (+ x 13))) a)" - `((before-after ((hilite (local ((define (a x) (+ x 13))) a))) ((hilite (define (a_0 x) (+ x 13))) (hilite a_0))) - (finished-stepping)))) + (t1 'local4 + m:intermediate "(local ((define (a x) (+ x 13))) a)" + `((before-after ((hilite (local ((define (a x) (+ x 13))) a))) ((hilite (define (a_0 x) (+ x 13))) (hilite a_0))) + (finished-stepping))) - (t1 local5 - (test-intermediate/lambda-sequence "(local ((define (a x) (+ x 13))) a)" - `((before-after ((hilite (local ((define (a x) (+ x 13))) a))) - ((hilite (define (a_0 x) (+ x 13))) (hilite a_0))) - (before-after ((define (a_0 x) (+ x 13)) (hilite a_0)) - ((define (a_0 x) (+ x 13)) (hilite (lambda (x) (+ x 13))))) - (finished-stepping)))) + (t1 'local5 + m:intermediate-lambda "(local ((define (a x) (+ x 13))) a)" + `((before-after ((hilite (local ((define (a x) (+ x 13))) a))) + ((hilite (define (a_0 x) (+ x 13))) (hilite a_0))) + (before-after ((define (a_0 x) (+ x 13)) (hilite a_0)) + ((define (a_0 x) (+ x 13)) (hilite (lambda (x) (+ x 13))))) + (finished-stepping))) - (t1 local-interref1 - (test-intermediate-sequence "(local ((define (a x) (+ x 9)) (define b a) (define p (+ 3 4))) (b 1))" - (let* ([defs1 `((define (a_0 x) (+ x 9)) (define b_0 a_0))] - [defs2 (append defs1 `((define p_0 7)))]) - `((before-after ((hilite (local ((define (a x) (+ x 9)) (define b a) (define p (+ 3 4))) (b 1)))) - ((hilite (define (a_0 x) (+ x 9))) (hilite (define b_0 a_0)) (hilite (define p_0 (+ 3 4))) (hilite (b_0 1)))) - (before-after (,@defs1 (define p_0 (hilite (+ 3 4))) (b_0 1)) - (,@defs1 (define p_0 (hilite 7)) (b_0 1))) - (before-after (,@defs2 ((hilite b_0) 1)) - (,@defs2 ((hilite a_0) 1))) - (before-after (,@defs2 (hilite (a_0 1))) - (,@defs2 (hilite (+ 1 9)))) - (before-after (,@defs2 (hilite (+ 1 9))) - (,@defs2 (hilite 10))) - (finished-stepping))))) + (t1 'local-interref1 + m:intermediate "(local ((define (a x) (+ x 9)) (define b a) (define p (+ 3 4))) (b 1))" + (let* ([defs1 `((define (a_0 x) (+ x 9)) (define b_0 a_0))] + [defs2 (append defs1 `((define p_0 7)))]) + `((before-after ((hilite (local ((define (a x) (+ x 9)) (define b a) (define p (+ 3 4))) (b 1)))) + ((hilite (define (a_0 x) (+ x 9))) (hilite (define b_0 a_0)) (hilite (define p_0 (+ 3 4))) (hilite (b_0 1)))) + (before-after (,@defs1 (define p_0 (hilite (+ 3 4))) (b_0 1)) + (,@defs1 (define p_0 (hilite 7)) (b_0 1))) + (before-after (,@defs2 ((hilite b_0) 1)) + (,@defs2 ((hilite a_0) 1))) + (before-after (,@defs2 (hilite (a_0 1))) + (,@defs2 (hilite (+ 1 9)))) + (before-after (,@defs2 (hilite (+ 1 9))) + (,@defs2 (hilite 10))) + (finished-stepping)))) - (t1 local-interref2 - (test-intermediate/lambda-sequence "(local ((define (a x) (+ x 9)) (define b a) (define p (+ 3 4))) (b 1))" - (let* ([defs1 `((define (a_0 x) (+ x 9)))] - [defs2 (append defs1 `((define b_0 (lambda (x) (+ x 9)))))] - [defs3 (append defs2 `((define p_0 7)))]) - `((before-after ((hilite (local ((define (a x) (+ x 9)) (define b a) (define p (+ 3 4))) (b 1)))) - ((hilite (define (a_0 x) (+ x 9))) (hilite (define b_0 a_0)) (hilite (define p_0 (+ 3 4))) (hilite (b_0 1)))) - (before-after (,@defs1 (define b_0 (hilite a_0)) (define p_0 (+ 3 4)) (b_0 1)) - (,@defs1 (define b_0 (hilite (lambda (x) (+ x 9)))) (define p_0 (+ 3 4)) (b_0 1))) - (before-after (,@defs2 (define p_0 (hilite (+ 3 4))) (b_0 1)) - (,@defs2 (define p_0 (hilite 7)) (b_0 1))) - (before-after (,@defs3 ((hilite b_0) 1)) - (,@defs3 ((hilite (lambda (x) (+ x 9))) 1))) - (before-after (,@defs3 (hilite ((lambda (x) (+ x 9)) 1))) - (,@defs3 (hilite (+ 1 9)))) - (before-after (,@defs3 (hilite (+ 1 9))) - (,@defs3 (hilite 10))) - (finished-stepping))))) + (t1 'local-interref2 + m:intermediate-lambda "(local ((define (a x) (+ x 9)) (define b a) (define p (+ 3 4))) (b 1))" + (let* ([defs1 `((define (a_0 x) (+ x 9)))] + [defs2 (append defs1 `((define b_0 (lambda (x) (+ x 9)))))] + [defs3 (append defs2 `((define p_0 7)))]) + `((before-after ((hilite (local ((define (a x) (+ x 9)) (define b a) (define p (+ 3 4))) (b 1)))) + ((hilite (define (a_0 x) (+ x 9))) (hilite (define b_0 a_0)) (hilite (define p_0 (+ 3 4))) (hilite (b_0 1)))) + (before-after (,@defs1 (define b_0 (hilite a_0)) (define p_0 (+ 3 4)) (b_0 1)) + (,@defs1 (define b_0 (hilite (lambda (x) (+ x 9)))) (define p_0 (+ 3 4)) (b_0 1))) + (before-after (,@defs2 (define p_0 (hilite (+ 3 4))) (b_0 1)) + (,@defs2 (define p_0 (hilite 7)) (b_0 1))) + (before-after (,@defs3 ((hilite b_0) 1)) + (,@defs3 ((hilite (lambda (x) (+ x 9))) 1))) + (before-after (,@defs3 (hilite ((lambda (x) (+ x 9)) 1))) + (,@defs3 (hilite (+ 1 9)))) + (before-after (,@defs3 (hilite (+ 1 9))) + (,@defs3 (hilite 10))) + (finished-stepping)))) - (t1 local-gprime - (test-intermediate-sequence "(define (f12 g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp)) (define gprime (f12 cos))" - (let ([defs `((define (f12 g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp)))]) - `((before-after (,@defs (define gprime (hilite (f12 cos)))) - (,@defs (define gprime (hilite (local ([define (gp x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)]) gp))))) - (before-after (,@defs (define gprime (hilite (local ([define (gp x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)]) gp)))) - (,@defs (hilite (define (gp_0 x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1))) (define gprime (hilite gp_0)))) - (finished-stepping))))) + (t1 'local-gprime + m:intermediate "(define (f12 g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp)) (define gprime (f12 cos))" + (let ([defs `((define (f12 g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp)))]) + `((before-after (,@defs (define gprime (hilite (f12 cos)))) + (,@defs (define gprime (hilite (local ([define (gp x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)]) gp))))) + (before-after (,@defs (define gprime (hilite (local ([define (gp x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)]) gp)))) + (,@defs (hilite (define (gp_0 x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1))) (define gprime (hilite gp_0)))) + (finished-stepping)))) - (t1 local-gprime/lambda - (test-intermediate/lambda-sequence "(define (f12 g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp)) (define gprime (f12 cos))" - (let ([defs `((define (f12 g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp)))]) - `((before-after (,@defs (define gprime ((hilite f12) cos))) - (,@defs (define gprime ((hilite (lambda (g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp))) cos)))) - (before-after (,@defs (define gprime (hilite ((lambda (g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp)) cos)))) - (,@defs (define gprime (hilite (local ([define (gp x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)]) gp))))) - (before-after (,@defs (define gprime (hilite (local ([define (gp x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)]) gp)))) - (,@defs (hilite (define (gp_0 x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1))) (define gprime (hilite gp_0)))) - (before-after (,@defs (define (gp_0 x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)) (define gprime (hilite gp_0))) - (,@defs - (define (gp_0 x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)) - (define gprime (hilite (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)))))) - (finished-stepping))))) + (t1 'local-gprime/lambda + m:intermediate-lambda "(define (f12 g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp)) (define gprime (f12 cos))" + (let ([defs `((define (f12 g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp)))]) + `((before-after (,@defs (define gprime ((hilite f12) cos))) + (,@defs (define gprime ((hilite (lambda (g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp))) cos)))) + (before-after (,@defs (define gprime (hilite ((lambda (g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp)) cos)))) + (,@defs (define gprime (hilite (local ([define (gp x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)]) gp))))) + (before-after (,@defs (define gprime (hilite (local ([define (gp x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)]) gp)))) + (,@defs (hilite (define (gp_0 x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1))) (define gprime (hilite gp_0)))) + (before-after (,@defs (define (gp_0 x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)) (define gprime (hilite gp_0))) + (,@defs + (define (gp_0 x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)) + (define gprime (hilite (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)))))) + (finished-stepping)))) ; test generativity... that is, multiple evaluations of a local should get different lifted names: - (t1 local-generative - (test-intermediate-sequence "(define (a13 b13 c13) (b13 c13)) (define (f9 x) (local ((define (maker dc) x)) maker)) (define m1 (f9 3)) (a13 (f9 4) 1)" - (let* ([defs1 `((define (a13 b13 c13) (b13 c13)) - (define (f9 x) (local ((define (maker dc) x)) maker)))] - [defs2 (append defs1 `((define (maker_0 dc) 3) (define m1 maker_0)))] - [defs3 (append defs2 `((define (maker_1 dc) 4)))]) - `((before-after (,@defs1 (define m1 (hilite (f9 3)))) - (,@defs1 (define m1 (hilite (local ((define (maker dc) 3)) maker))))) - (before-after (,@defs1 (define m1 (hilite (local ((define (maker dc) 3)) maker)))) - (,@defs1 (hilite (define (maker_0 dc) 3)) (define m1 (hilite maker_0)))) - (before-after (,@defs2 (a13 (hilite (f9 4)) 1)) - (,@defs2 (a13 (hilite (local ((define (maker dc) 4)) maker)) 1))) - (before-after (,@defs2 (a13 (hilite (local ((define (maker dc) 4)) maker)) 1)) - (,@defs2 (hilite (define (maker_1 dc) 4)) (a13 (hilite maker_1) 1))) - (before-after (,@defs3 (hilite (a13 maker_1 1))) - (,@defs3 (hilite (maker_1 1)))) - (before-after (,@defs3 (hilite (maker_1 1))) - (,@defs3 (hilite 4))) - (finished-stepping))))) + (t1 'local-generative + m:intermediate "(define (a13 b13 c13) (b13 c13)) (define (f9 x) (local ((define (maker dc) x)) maker)) (define m1 (f9 3)) (a13 (f9 4) 1)" + (let* ([defs1 `((define (a13 b13 c13) (b13 c13)) + (define (f9 x) (local ((define (maker dc) x)) maker)))] + [defs2 (append defs1 `((define (maker_0 dc) 3) (define m1 maker_0)))] + [defs3 (append defs2 `((define (maker_1 dc) 4)))]) + `((before-after (,@defs1 (define m1 (hilite (f9 3)))) + (,@defs1 (define m1 (hilite (local ((define (maker dc) 3)) maker))))) + (before-after (,@defs1 (define m1 (hilite (local ((define (maker dc) 3)) maker)))) + (,@defs1 (hilite (define (maker_0 dc) 3)) (define m1 (hilite maker_0)))) + (before-after (,@defs2 (a13 (hilite (f9 4)) 1)) + (,@defs2 (a13 (hilite (local ((define (maker dc) 4)) maker)) 1))) + (before-after (,@defs2 (a13 (hilite (local ((define (maker dc) 4)) maker)) 1)) + (,@defs2 (hilite (define (maker_1 dc) 4)) (a13 (hilite maker_1) 1))) + (before-after (,@defs3 (hilite (a13 maker_1 1))) + (,@defs3 (hilite (maker_1 1)))) + (before-after (,@defs3 (hilite (maker_1 1))) + (,@defs3 (hilite 4))) + (finished-stepping)))) - (t1 local-generative/lambda - (test-intermediate/lambda-sequence "(define (a13 b13 c13) (b13 c13)) (define (f9 x) (local ((define (maker dc) x)) maker)) (define m1 (f9 3)) (a13 (f9 4) 1)" - (let* ([defs1 `((define (a13 b13 c13) (b13 c13)) - (define (f9 x) (local ((define (maker dc) x)) maker)))] - [defs2 (append defs1 `((define (maker_0 dc) 3)))] - [defs3 (append defs2 `((define m1 (lambda (dc) 3))))] - [defs4 (append defs3 `((define (maker_1 dc) 4)))]) - `((before-after (,@defs1 (define m1 ((hilite f9) 3))) - (,@defs1 (define m1 ((hilite (lambda (x) (local ((define (maker dc) x)) maker))) 3)))) - (before-after (,@defs1 (define m1 (hilite ((lambda (x) (local ((define (maker dc) x)) maker)) 3)))) - (,@defs1 (define m1 (hilite (local ((define (maker dc) 3)) maker))))) - (before-after (,@defs1 (define m1 (hilite (local ((define (maker dc) 3)) maker)))) - (,@defs1 (hilite (define (maker_0 dc) 3)) (define m1 (hilite maker_0)))) - (before-after (,@defs2 (define m1 (hilite maker_0))) - (,@defs2 (define m1 (hilite (lambda (dc) 3))))) - (before-after (,@defs3 ((hilite a13) (f9 4) 1)) - (,@defs3 ((hilite (lambda (b13 c13) (b13 c13))) (f9 4) 1))) - (before-after (,@defs3 ((lambda (b13 c13) (b13 c13)) ((hilite f9) 4) 1)) - (,@defs3 ((lambda (b13 c13) (b13 c13)) ((hilite (lambda (x) (local ((define (maker dc) x)) maker))) 4) 1))) - (before-after (,@defs3 ((lambda (b13 c13) (b13 c13)) (hilite ((lambda (x) (local ((define (maker dc) x)) maker)) 4)) 1)) - (,@defs3 ((lambda (b13 c13) (b13 c13)) (hilite (local ((define (maker dc) 4)) maker)) 1))) - (before-after (,@defs3 ((lambda (b13 c13) (b13 c13)) (hilite (local ((define (maker dc) 4)) maker)) 1)) - (,@defs3 (hilite (define (maker_1 dc) 4)) ((lambda (b13 c13) (b13 c13)) (hilite maker_1) 1))) - (before-after (,@defs4 ((lambda (b13 c13) (b13 c13)) (hilite maker_1) 1)) - (,@defs4 ((lambda (b13 c13) (b13 c13)) (hilite (lambda (dc) 4)) 1))) - (before-after (,@defs4 (hilite ((lambda (b13 c13) (b13 c13)) (lambda (dc) 4) 1))) - (,@defs4 (hilite ((lambda (dc) 4) 1)))) - (before-after (,@defs4 (hilite ((lambda (dc) 4) 1))) - (,@defs4 (hilite 4))) - (finished-stepping))))) + (t1 'local-generative/lambda + m:intermediate-lambda "(define (a13 b13 c13) (b13 c13)) (define (f9 x) (local ((define (maker dc) x)) maker)) (define m1 (f9 3)) (a13 (f9 4) 1)" + (let* ([defs1 `((define (a13 b13 c13) (b13 c13)) + (define (f9 x) (local ((define (maker dc) x)) maker)))] + [defs2 (append defs1 `((define (maker_0 dc) 3)))] + [defs3 (append defs2 `((define m1 (lambda (dc) 3))))] + [defs4 (append defs3 `((define (maker_1 dc) 4)))]) + `((before-after (,@defs1 (define m1 ((hilite f9) 3))) + (,@defs1 (define m1 ((hilite (lambda (x) (local ((define (maker dc) x)) maker))) 3)))) + (before-after (,@defs1 (define m1 (hilite ((lambda (x) (local ((define (maker dc) x)) maker)) 3)))) + (,@defs1 (define m1 (hilite (local ((define (maker dc) 3)) maker))))) + (before-after (,@defs1 (define m1 (hilite (local ((define (maker dc) 3)) maker)))) + (,@defs1 (hilite (define (maker_0 dc) 3)) (define m1 (hilite maker_0)))) + (before-after (,@defs2 (define m1 (hilite maker_0))) + (,@defs2 (define m1 (hilite (lambda (dc) 3))))) + (before-after (,@defs3 ((hilite a13) (f9 4) 1)) + (,@defs3 ((hilite (lambda (b13 c13) (b13 c13))) (f9 4) 1))) + (before-after (,@defs3 ((lambda (b13 c13) (b13 c13)) ((hilite f9) 4) 1)) + (,@defs3 ((lambda (b13 c13) (b13 c13)) ((hilite (lambda (x) (local ((define (maker dc) x)) maker))) 4) 1))) + (before-after (,@defs3 ((lambda (b13 c13) (b13 c13)) (hilite ((lambda (x) (local ((define (maker dc) x)) maker)) 4)) 1)) + (,@defs3 ((lambda (b13 c13) (b13 c13)) (hilite (local ((define (maker dc) 4)) maker)) 1))) + (before-after (,@defs3 ((lambda (b13 c13) (b13 c13)) (hilite (local ((define (maker dc) 4)) maker)) 1)) + (,@defs3 (hilite (define (maker_1 dc) 4)) ((lambda (b13 c13) (b13 c13)) (hilite maker_1) 1))) + (before-after (,@defs4 ((lambda (b13 c13) (b13 c13)) (hilite maker_1) 1)) + (,@defs4 ((lambda (b13 c13) (b13 c13)) (hilite (lambda (dc) 4)) 1))) + (before-after (,@defs4 (hilite ((lambda (b13 c13) (b13 c13)) (lambda (dc) 4) 1))) + (,@defs4 (hilite ((lambda (dc) 4) 1)))) + (before-after (,@defs4 (hilite ((lambda (dc) 4) 1))) + (,@defs4 (hilite 4))) + (finished-stepping)))) ;;;;;;;;;;;;; ;; @@ -1207,32 +935,32 @@ ;; ;;;;;;;;;;;;; - (t1 int/lam1 - (test-intermediate/lambda-sequence "(define f ((lambda (x) x) (lambda (x) x))) (f f)" - (let ([defs `((define f (lambda (x) x)))]) - `((before-after ((define f (hilite ((lambda (x) x) (lambda (x) x))))) - ((define f (hilite (lambda (x) x))))) - (before-after (,@defs ((hilite f) f)) - (,@defs ((hilite (lambda (x) x)) f))) - (before-after (,@defs ((lambda (x) x) (hilite f))) - (,@defs ((lambda (x) x) (hilite (lambda (x) x))))) - (before-after (,@defs (hilite ((lambda (x) x) (lambda (x) x)))) - (,@defs (hilite (lambda (x) x)))) - (finished-stepping))))) + (t1 'int/lam1 + m:intermediate-lambda "(define f ((lambda (x) x) (lambda (x) x))) (f f)" + (let ([defs `((define f (lambda (x) x)))]) + `((before-after ((define f (hilite ((lambda (x) x) (lambda (x) x))))) + ((define f (hilite (lambda (x) x))))) + (before-after (,@defs ((hilite f) f)) + (,@defs ((hilite (lambda (x) x)) f))) + (before-after (,@defs ((lambda (x) x) (hilite f))) + (,@defs ((lambda (x) x) (hilite (lambda (x) x))))) + (before-after (,@defs (hilite ((lambda (x) x) (lambda (x) x)))) + (,@defs (hilite (lambda (x) x)))) + (finished-stepping)))) - (t1 int/lam2 - (test-intermediate/lambda-sequence "(define f (if false (lambda (x) x) (lambda (x) x))) (f f)" - (let ([defs `((define f (lambda (x) x)))]) - `((before-after ((define f (hilite (if false (lambda (x) x) (lambda (x) x))))) - ((define f (hilite (lambda (x) x))))) - (before-after (,@defs ((hilite f) f)) - (,@defs ((hilite (lambda (x) x)) f))) - (before-after (,@defs ((lambda (x) x) (hilite f))) - (,@defs ((lambda (x) x) (hilite (lambda (x) x))))) - (before-after (,@defs (hilite ((lambda (x) x) (lambda (x) x)))) - (,@defs (hilite (lambda (x) x)))) - (finished-stepping))))) + (t1 'int/lam2 + m:intermediate-lambda "(define f (if false (lambda (x) x) (lambda (x) x))) (f f)" + (let ([defs `((define f (lambda (x) x)))]) + `((before-after ((define f (hilite (if false (lambda (x) x) (lambda (x) x))))) + ((define f (hilite (lambda (x) x))))) + (before-after (,@defs ((hilite f) f)) + (,@defs ((hilite (lambda (x) x)) f))) + (before-after (,@defs ((lambda (x) x) (hilite f))) + (,@defs ((lambda (x) x) (hilite (lambda (x) x))))) + (before-after (,@defs (hilite ((lambda (x) x) (lambda (x) x)))) + (,@defs (hilite (lambda (x) x)))) + (finished-stepping)))) ; ; ;;;;;;;;;;;;; @@ -1242,11 +970,11 @@ ; ;;;;;;;;;;;;; ; - (t1 time - (test-intermediate-sequence "(time (+ 3 4))" - `((before-after ((hilite (+ 3 4))) - ((hilite 7))) - (finished-stepping)))) + (t1 'time + m:intermediate "(time (+ 3 4))" + `((before-after ((hilite (+ 3 4))) + ((hilite 7))) + (finished-stepping))) ;;;;;;;;;;;;;;;; @@ -1258,8 +986,8 @@ ;; NOT UPDATED FOR NEW TEST CASE FORMAT #; - (t1 ddj-screenshot - (test-mz-sequence (define-syntax (xml stx) + (t1 'ddj-screenshot + (m:mz (define-syntax (xml stx) (letrec ([process-xexpr (lambda (xexpr) (syntax-case xexpr (lmx lmx-splice) @@ -1318,30 +1046,30 @@ #; (define (test-xml-beginner-sequence spec expected) - (test-xml-sequence `(lib "htdp-beginner.ss" "lang") - fake-beginner-render-settings - #t - spec - expected)) + test-xml-sequence `(lib "htdp-beginner.ss" "lang") + fake-beginner-render-settings + #t + spec + expected) #; - (t1 xml-box1 - (test-xml-beginner-sequence `((xml-box "3")) - `((finished-stepping)))) + (t1 'xml-box1 + test-xml-beginner-sequence `((xml-box "3")) + `((finished-stepping))) #; - (t1 xml-box2 - (text-xml-beginnner-sequence `("(cdr (cdr " (xml-box "a b") "))") - `((before-after ((cdr (cdr (xml-box "a b")))))))) + (t1 'xml-box2 + text-xml-beginnner-sequence `("(cdr (cdr " (xml-box "a b") "))") + `((before-after ((cdr (cdr (xml-box "a b"))))))) - ;(t1 filled-rect-image - ; (test-upto-int-lam "(image-width (filled-rect 10 10 'blue))" + ;(t1 'filled-rect-image + ; (m:upto-int-lam "(image-width (filled-rect 10 10 'blue))" ; `((before-after ((image-width (hilite (filled-rect 10 10 'blue)))) ((image-width (hilite ))))))) ; add image test: (image-width (filled-rect 10 10 'blue)) - (t check-expect test-upto-int/lam + (t 'check-expect m:upto-int/lam (check-expect (+ 3 4) (+ 8 9)) (check-expect (+ 1 1) 2) (check-expect (+ 2 2) 4) (+ 4 5) :: {(+ 4 5)} -> {9} :: 9 (check-expect (+ 3 4) {(+ 8 9)}) -> 9 (check-expect (+ 3 4) {17}) @@ -1349,57 +1077,57 @@ :: 9 false (check-expect {(+ 1 1)} 2) -> 9 false (check-expect {2} 2) :: 9 false true (check-expect {(+ 2 2)} 4) -> 9 false true (check-expect {4} 4)) - (t1 check-within - (test-upto-int/lam - "(check-within (+ 3 4) (+ 8 10) (+ 10 90)) (check-expect (+ 1 1) 2)(+ 4 5)" - `((before-after ((hilite (+ 4 5))) - ((hilite 9))) - (before-after (9 (check-within (+ 3 4) (hilite (+ 8 10)) (+ 10 90))) - (9 (check-within (+ 3 4) (hilite 18) (+ 10 90)))) - (before-after (9 (check-within (+ 3 4) 18 (hilite (+ 10 90)))) - (9 (check-within (+ 3 4) 18 (hilite 100)))) - (before-after (9 (check-within (hilite (+ 3 4)) 18 100)) - (9 (check-within (hilite 7) 18 100))) - (before-after (9 true (check-expect (hilite (+ 1 1)) 2)) - (9 true (check-expect (hilite 2) 2)))))) + (t1 'check-within + m:upto-int/lam + "(check-within (+ 3 4) (+ 8 10) (+ 10 90)) (check-expect (+ 1 1) 2)(+ 4 5)" + `((before-after ((hilite (+ 4 5))) + ((hilite 9))) + (before-after (9 (check-within (+ 3 4) (hilite (+ 8 10)) (+ 10 90))) + (9 (check-within (+ 3 4) (hilite 18) (+ 10 90)))) + (before-after (9 (check-within (+ 3 4) 18 (hilite (+ 10 90)))) + (9 (check-within (+ 3 4) 18 (hilite 100)))) + (before-after (9 (check-within (hilite (+ 3 4)) 18 100)) + (9 (check-within (hilite 7) 18 100))) + (before-after (9 true (check-expect (hilite (+ 1 1)) 2)) + (9 true (check-expect (hilite 2) 2))))) - (t1 check-within-bad - (test-upto-int/lam - "(check-within (+ 3 4) (+ 8 10) 0.01) (+ 4 5) (check-expect (+ 1 1) 2)" - `((before-after ((hilite (+ 4 5))) - ((hilite 9))) - (before-after (9 (check-within (+ 3 4) (hilite (+ 8 10)) 0.01)) - (9 (check-within (+ 3 4) (hilite 18) 0.01))) - (before-after (9 (check-within (hilite (+ 3 4)) 18 0.01)) - (9 (check-within (hilite 7) 18 0.01))) - (before-after (9 false (check-expect (hilite (+ 1 1)) 2)) - (9 false (check-expect (hilite 2) 2)))))) + (t1 'check-within-bad + m:upto-int/lam + "(check-within (+ 3 4) (+ 8 10) 0.01) (+ 4 5) (check-expect (+ 1 1) 2)" + `((before-after ((hilite (+ 4 5))) + ((hilite 9))) + (before-after (9 (check-within (+ 3 4) (hilite (+ 8 10)) 0.01)) + (9 (check-within (+ 3 4) (hilite 18) 0.01))) + (before-after (9 (check-within (hilite (+ 3 4)) 18 0.01)) + (9 (check-within (hilite 7) 18 0.01))) + (before-after (9 false (check-expect (hilite (+ 1 1)) 2)) + (9 false (check-expect (hilite 2) 2))))) (let ([errmsg "rest: expected argument of type ; given ()"]) - (t1 check-error - (test-upto-int/lam - "(check-error (+ (+ 3 4) (rest empty)) (string-append \"rest: \" \"expected argument of type ; given ()\")) (check-expect (+ 3 1) 4) (+ 4 5)" - `((before-after ((hilite (+ 4 5))) - ((hilite 9))) - (before-after (9 (check-error (+ (+ 3 4) (rest empty)) (hilite (string-append "rest: " "expected argument of type ; given ()")))) - (9 (check-error (+ (+ 3 4) (rest empty)) (hilite ,errmsg)))) - (before-after (9 (check-error (+ (hilite (+ 3 4)) (rest empty)) ,errmsg)) - (9 (check-error (+ (hilite 7) (rest empty)) ,errmsg))) - (before-after (9 true (check-expect (hilite (+ 3 1)) 4)) - (9 true (check-expect (hilite 4) 4))))))) + (t1 'check-error + m:upto-int/lam + "(check-error (+ (+ 3 4) (rest empty)) (string-append \"rest: \" \"expected argument of type ; given ()\")) (check-expect (+ 3 1) 4) (+ 4 5)" + `((before-after ((hilite (+ 4 5))) + ((hilite 9))) + (before-after (9 (check-error (+ (+ 3 4) (rest empty)) (hilite (string-append "rest: " "expected argument of type ; given ()")))) + (9 (check-error (+ (+ 3 4) (rest empty)) (hilite ,errmsg)))) + (before-after (9 (check-error (+ (hilite (+ 3 4)) (rest empty)) ,errmsg)) + (9 (check-error (+ (hilite 7) (rest empty)) ,errmsg))) + (before-after (9 true (check-expect (hilite (+ 3 1)) 4)) + (9 true (check-expect (hilite 4) 4)))))) - (t1 check-error-bad - (test-upto-int/lam - "(check-error (+ (+ 3 4) (rest empty)) (string-append \"b\" \"ogus\")) (check-expect (+ 3 1) 4) (+ 4 5)" - `((before-after ((hilite (+ 4 5))) - ((hilite 9))) - (before-after (9 (check-error (+ (+ 3 4) (rest empty)) (hilite (string-append "b" "ogus")))) - (9 (check-error (+ (+ 3 4) (rest empty)) (hilite "bogus")))) - (before-after (9 (check-error (+ (hilite (+ 3 4)) (rest empty)) "bogus")) - (9 (check-error (+ (hilite 7) (rest empty)) "bogus"))) - (before-after (9 false (check-expect (hilite (+ 3 1)) 4)) - (9 false (check-expect (hilite 4) 4)))))) + (t1 'check-error-bad + m:upto-int/lam + "(check-error (+ (+ 3 4) (rest empty)) (string-append \"b\" \"ogus\")) (check-expect (+ 3 1) 4) (+ 4 5)" + `((before-after ((hilite (+ 4 5))) + ((hilite 9))) + (before-after (9 (check-error (+ (+ 3 4) (rest empty)) (hilite (string-append "b" "ogus")))) + (9 (check-error (+ (+ 3 4) (rest empty)) (hilite "bogus")))) + (before-after (9 (check-error (+ (hilite (+ 3 4)) (rest empty)) "bogus")) + (9 (check-error (+ (hilite 7) (rest empty)) "bogus"))) + (before-after (9 false (check-expect (hilite (+ 3 1)) 4)) + (9 false (check-expect (hilite 4) 4))))) ; ;;;;;;;;;;;;; ; ;; @@ -1412,15 +1140,8 @@ ;; (require mred) - (define test-teachpack-sequence (lambda (teachpack-specs expr-string expected-results) - ;(let ([new-custodian (make-custodian)]) - ; (parameterize ([current-custodian new-custodian]) - ; (parameterize ([current-eventspace (make-eventspace)]) - (test-sequence `(lib "htdp-beginner.ss" "lang") teachpack-specs fake-beginner-render-settings #f #f expr-string expected-results) - ;)) - ; (custodian-shutdown-all new-custodian)) - )) - + (define (make-teachpack-ll-model teachpack-specs) + (m:make-ll-model `(lib "htdp-beginner.ss" "lang") teachpack-specs fake-beginner-render-settings #f #f)) ; uses set-render-settings! ;(reconstruct:set-render-settings! fake-beginner-render-settings) @@ -1431,69 +1152,70 @@ ; tp-namespace) #; - (t1 teachpack-drawing - (test-teachpack-sequence - `((lib "draw.ss" "htdp")) - "(define (draw-limb i) (cond + (t1 'teachpack-drawing + (make-teachpack-ll-model + `((lib "draw.ss" "htdp"))) + "(define (draw-limb i) (cond [(= i 1) (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] [(= i 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)])) (and (start 100 100) (draw-limb 0))" - `((before-after-finished ((define (draw-limb i) (cond [(= i 1) (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] - [(= i 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)]))) - ((and (hilite (start 100 100)) (draw-limb 0))) - ((and (hilite true) (draw-limb 0)))) - (before-after ((and true (hilite (draw-limb 0)))) - ((and true (hilite (cond [(= 0 1) (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] - [(= 0 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)]))))) - (before-after ((and true (cond [(hilite (= 0 1)) (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] - [(= 0 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)]))) - ((and true (cond [(hilite false) (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] - [(= 0 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)])))) - (before-after ((and true (hilite (cond [false (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] - [(= 0 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)])))) - ((and true (hilite (cond [(= 0 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)]))))) - (before-after ((and true (cond [(hilite (= 0 0)) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)]))) - ((and true (cond [(hilite true) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)])))) - (before-after ((and true (hilite (cond [true (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)])))) - ((and true (hilite (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red))))) - (before-after ((and true (draw-solid-line (make-posn (hilite (+ 1 10)) 10) (make-posn 10 100) 'red))) - ((and true (draw-solid-line (make-posn (hilite 11) 10) (make-posn 10 100) 'red)))) - (before-after ((and true (hilite (draw-solid-line (make-posn 11 10) (make-posn 10 100) 'red)))) - ((and true (hilite true)))) - (before-after ((hilite (and true true))) - ((hilite true))) - (finished-stepping)))) + `((before-after-finished ((define (draw-limb i) (cond [(= i 1) (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] + [(= i 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)]))) + ((and (hilite (start 100 100)) (draw-limb 0))) + ((and (hilite true) (draw-limb 0)))) + (before-after ((and true (hilite (draw-limb 0)))) + ((and true (hilite (cond [(= 0 1) (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] + [(= 0 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)]))))) + (before-after ((and true (cond [(hilite (= 0 1)) (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] + [(= 0 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)]))) + ((and true (cond [(hilite false) (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] + [(= 0 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)])))) + (before-after ((and true (hilite (cond [false (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] + [(= 0 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)])))) + ((and true (hilite (cond [(= 0 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)]))))) + (before-after ((and true (cond [(hilite (= 0 0)) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)]))) + ((and true (cond [(hilite true) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)])))) + (before-after ((and true (hilite (cond [true (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)])))) + ((and true (hilite (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red))))) + (before-after ((and true (draw-solid-line (make-posn (hilite (+ 1 10)) 10) (make-posn 10 100) 'red))) + ((and true (draw-solid-line (make-posn (hilite 11) 10) (make-posn 10 100) 'red)))) + (before-after ((and true (hilite (draw-solid-line (make-posn 11 10) (make-posn 10 100) 'red)))) + ((and true (hilite true)))) + (before-after ((hilite (and true true))) + ((hilite true))) + (finished-stepping))) - #;(t1 teachpack-universe - (test-teachpack-sequence - `((lib "universe.ss" "2htdp")) - "(define (z world) + #;(t1 'teachpack-universe + (test-teachpack-sequence + `((lib "universe.ss" "2htdp"))) + "(define (z world) (empty-scene 100 100)) (big-bang 3 (on-tick add1) (on-draw z))" - `((finished-stepping)))) + `((finished-stepping))) + #; - (t1 teachpack-name-rendering - (test-teachpack-sequence - `((file "/Users/clements/plt/teachpack/htdp/draw.ss")) + (t1 'teachpack-name-rendering + (test-teachpack-sequence + `((file "/Users/clements/plt/teachpack/htdp/draw.ss"))) "(start 300 300) (if true (get-key-event) 3)" `((before-after ((hilite (start 300 300))) - ((hilite true))) + ((hilite true))) (before-after-finished (true) ((hilite (if true (get-key-event) 3))) ((hilite (get-key-event)))) (before-after ((hilite (get-key-event))) ((hilite false))) - (finished-stepping)))) + (finished-stepping))) #; - (t1 teachpack-hop-names - (test-teachpack-sequence - `((file "/Users/clements/plt/teachpack/htdp/draw.ss")) + (t1 'teachpack-hop-names + (make-teachpack-ll-model + `((file "/Users/clements/plt/teachpack/htdp/draw.ss"))) "(start 300 300) (define (a x y) (+ 3 4)) (if true (on-key-event a) 3)" `((before-after ((hilite (start 300 300))) ((hilite true))) @@ -1502,32 +1224,32 @@ ((hilite (on-key-event a)))) (before-after ((hilite (on-key-event a))) ((hilite true))) - (finished-stepping)))) + (finished-stepping))) #; - (t1 teachpack-web-interaction - (test-teachpack-sequence - `(htdp/servlet2) - "(define (adder go) (inform (number->string (+ (single-query (make-number \"enter 10\")) (single-query (make-number \"enter 20\")))))) (adder true)" - `((before-after-finished ((define (adder go) (inform (number->string (+ (single-query (make-number "enter 10")) (single-query (make-number "enter 20"))))))) - ((hilite (adder true))) - ((hilite (inform (number->string (+ (single-query (make-number "enter 10")) (single-query (make-number "enter 20")))))))) - (before-after ((inform (number->string (+ (single-query (hilite (make-number "enter 10"))) (single-query (make-number "enter 20")))))) ; this step looks wrong wrong wrong. - ((inform (number->string (+ (single-query (hilite (make-numeric "enter 10"))) (single-query (make-number "enter 20"))))))) - (before-after ((inform (number->string (+ (hilite (single-query (make-numeric "enter 10"))) (single-query (make-number "enter 20")))))) - ((inform (number->string (+ (hilite 10) (single-query (make-number "enter 20"))))))) - (before-after ((inform (number->string (+ 10 (single-query (hilite (make-number "enter 20"))))))) - ((inform (number->string (+ 10 (single-query (hilite (make-numeric "enter 20")))))))) - (before-after ((inform (number->string (+ 10 (hilite (single-query (make-numeric "enter 20"))))))) - ((inform (nut - mber->string (+ 10 (hilite 20)))))) - (before-after ((inform (number->string (hilite (+ 10 20))))) - ((inform (number->string (hilite 30))))) - (before-after ((inform (hilite (number->string 30)))) - ((inform (hilite "30")))) - (before-after ((hilite (inform "30"))) - ((hilite true))) - (finished-stepping)))) + (t1 'teachpack-web-interaction + (make-teachpack-ll-model + `(htdp/servlet2)) + "(define (adder go) (inform (number->string (+ (single-query (make-number \"enter 10\")) (single-query (make-number \"enter 20\")))))) (adder true)" + `((before-after-finished ((define (adder go) (inform (number->string (+ (single-query (make-number "enter 10")) (single-query (make-number "enter 20"))))))) + ((hilite (adder true))) + ((hilite (inform (number->string (+ (single-query (make-number "enter 10")) (single-query (make-number "enter 20")))))))) + (before-after ((inform (number->string (+ (single-query (hilite (make-number "enter 10"))) (single-query (make-number "enter 20")))))) ; this step looks wrong wrong wrong. + ((inform (number->string (+ (single-query (hilite (make-numeric "enter 10"))) (single-query (make-number "enter 20"))))))) + (before-after ((inform (number->string (+ (hilite (single-query (make-numeric "enter 10"))) (single-query (make-number "enter 20")))))) + ((inform (number->string (+ (hilite 10) (single-query (make-number "enter 20"))))))) + (before-after ((inform (number->string (+ 10 (single-query (hilite (make-number "enter 20"))))))) + ((inform (number->string (+ 10 (single-query (hilite (make-numeric "enter 20")))))))) + (before-after ((inform (number->string (+ 10 (hilite (single-query (make-numeric "enter 20"))))))) + ((inform (nut + mber->string (+ 10 (hilite 20)))))) + (before-after ((inform (number->string (hilite (+ 10 20))))) + ((inform (number->string (hilite 30))))) + (before-after ((inform (hilite (number->string 30)))) + ((inform (hilite "30")))) + (before-after ((hilite (inform "30"))) + ((hilite true))) + (finished-stepping))) ;;;;;;;;;;;;; @@ -1536,28 +1258,28 @@ ;; ;;;;;;;;;;;;; - (t1 top-ref-to-lifted - (test-advanced-sequence "(define a (local ((define i1 0) (define (i2 x) i1)) i2)) (+ 3 4)" - (let ([defs `((define i1_0 0) (define (i2_0 x) i1_0))]) - `((before-after ((define a (hilite (local ((define i1 0) (define (i2 x) i1)) i2)))) - ((hilite (define i1_0 0)) (hilite (define (i2_0 x) i1_0)) (define a (hilite i2_0)))) - (before-after (,@defs (define a (hilite i2_0))) - (,@defs (define a (hilite (lambda (x) i1_0))))) - (before-after (,@defs (define a (lambda (x) i1_0)) (hilite (+ 3 4))) - (,@defs (define a (lambda (x) i1_0)) (hilite 7))))))) + (t1 'top-ref-to-lifted + m:advanced "(define a (local ((define i1 0) (define (i2 x) i1)) i2)) (+ 3 4)" + (let ([defs `((define i1_0 0) (define (i2_0 x) i1_0))]) + `((before-after ((define a (hilite (local ((define i1 0) (define (i2 x) i1)) i2)))) + ((hilite (define i1_0 0)) (hilite (define (i2_0 x) i1_0)) (define a (hilite i2_0)))) + (before-after (,@defs (define a (hilite i2_0))) + (,@defs (define a (hilite (lambda (x) i1_0))))) + (before-after (,@defs (define a (lambda (x) i1_0)) (hilite (+ 3 4))) + (,@defs (define a (lambda (x) i1_0)) (hilite 7)))))) - (t1 set! - (test-advanced-sequence "(define a 3) (set! a (+ 4 5)) a" - `((before-after ((define a 3) (set! a (hilite (+ 4 5)))) - ((define a 3) (set! a (hilite 9)))) - (before-after ((hilite (define a 3)) (hilite (set! a 9))) - ((hilite (define a 9)) (hilite (void)))) - (before-after ((define a 9) (void) (hilite a)) - ((define a 9) (void) (hilite 9))) - (finished-stepping)))) + (t1 'set! + m:advanced "(define a 3) (set! a (+ 4 5)) a" + `((before-after ((define a 3) (set! a (hilite (+ 4 5)))) + ((define a 3) (set! a (hilite 9)))) + (before-after ((hilite (define a 3)) (hilite (set! a 9))) + ((hilite (define a 9)) (hilite (void)))) + (before-after ((define a 9) (void) (hilite a)) + ((define a 9) (void) (hilite 9))) + (finished-stepping))) - (t1 local-set! - (test-advanced-sequence + (t1 'local-set! + m:advanced "(define a (local ((define in 14) (define (getter dc) in) (define (modder n) (set! in n))) modder)) (a 15)" (let ([d1 `(define in_0 14)] [d2 `(define (getter_0 dc) in_0)] @@ -1573,7 +1295,7 @@ (,d1 ,d2 ,d3 ,d4 (hilite (set! in_0 15)))) (before-after ((hilite ,d1) ,d2 ,d3 , d4 (hilite (set! in_0 15))) ((hilite (define in_0 15)) ,d2 ,d3 ,d4 (void))) - (finished-stepping))))) + (finished-stepping)))) ;;;;;;;;;;; ;; @@ -1581,25 +1303,25 @@ ;; ;;;;;;;;;;; - (t1 simple-begin - (test-advanced-sequence "(+ 3 (begin 4 5))" - `((before-after ((+ 3 (hilite (begin 4 5)))) - ((+ 3 (hilite 5)))) - (before-after ((hilite (+ 3 5))) - ((hilite 8))) - (finished-stepping)))) + (t1 'simple-begin + m:advanced "(+ 3 (begin 4 5))" + `((before-after ((+ 3 (hilite (begin 4 5)))) + ((+ 3 (hilite 5)))) + (before-after ((hilite (+ 3 5))) + ((hilite 8))) + (finished-stepping))) - (t1 begin-onlyvalues - (test-advanced-sequence "(+ 3 (begin 4 5 6))" - `((before-after ((+ 3 (hilite (begin 4 5 6)))) - ((+ 3 (hilite (begin 5 6))))) - (before-after ((+ 3 (hilite (begin 5 6)))) - ((+ 3 (hilite 6)))) - (before-after ((hilite (+ 3 6))) - ((hilite 9)))))) + (t1 'begin-onlyvalues + m:advanced "(+ 3 (begin 4 5 6))" + `((before-after ((+ 3 (hilite (begin 4 5 6)))) + ((+ 3 (hilite (begin 5 6))))) + (before-after ((+ 3 (hilite (begin 5 6)))) + ((+ 3 (hilite 6)))) + (before-after ((hilite (+ 3 6))) + ((hilite 9))))) - (t1 begin - (test-advanced-sequence "(begin (+ 3 4) (+ 4 5) (+ 9 8))" + (t1 'begin + m:advanced "(begin (+ 3 4) (+ 4 5) (+ 9 8))" `((before-after ((begin (hilite (+ 3 4)) (+ 4 5) (+ 9 8))) ((begin (hilite 7) (+ 4 5) (+ 9 8)))) (before-after ((hilite (begin 7 (+ 4 5) (+ 9 8)))) @@ -1610,18 +1332,18 @@ ((hilite (+ 9 8)))) (before-after ((hilite (+ 9 8))) ((hilite 17))) - (finished-stepping)))) + (finished-stepping))) - (t begin-let-bug test-advanced-sequence + (t 'begin-let-bug m:advanced (let ([x 3]) (begin 3 4)) :: {(let ([x 3]) (begin 3 4))} -> {(define x_0 3)} {(begin 3 4)} :: (define x_0 3) {(begin 3 4)} -> (define x_0 3) 4) - (t1 empty-begin - (test-advanced-sequence "(begin)" - `((error "begin: expected a sequence of expressions after `begin', but nothing's there")))) + (t1 'empty-begin + m:advanced "(begin)" + `((error "begin: expected a sequence of expressions after `begin', but nothing's there"))) ;;;;;;;;;;;; ;; @@ -1629,32 +1351,32 @@ ;; ;;;;;;;;;;;; - (t1 empty-begin0 - (test-advanced-sequence "(begin0)" - `((error "begin0: expected a sequence of expressions after `begin0', but nothing's there")))) + (t1 'empty-begin0 + m:advanced "(begin0)" + `((error "begin0: expected a sequence of expressions after `begin0', but nothing's there"))) - (t1 trivial-begin0 - (test-advanced-sequence "(begin0 3)" + (t1 'trivial-begin0 + m:advanced "(begin0 3)" `((before-after ((hilite (begin0 3))) - ((hilite 3))) - (finished-stepping)))) + ((hilite 3))) + (finished-stepping))) - ;; urg... the first element of a begin0 is in tail position if there's only one. - (t1 one-item-begin0 - (test-advanced-sequence "(begin0 (+ 3 4))" - `((before-after ((hilite (begin0 (+ 3 4)))) - ((hilite (+ 3 4)))) - (before-after ((hilite (+ 3 4))) - ((hilite 7))) - (finished-stepping)))) + ;; urg.. the first element of a begin0 is in tail position if there's only one. + (t1 'one-item-begin0 + m:advanced "(begin0 (+ 3 4))" + `((before-after ((hilite (begin0 (+ 3 4)))) + ((hilite (+ 3 4)))) + (before-after ((hilite (+ 3 4))) + ((hilite 7))) + (finished-stepping))) - (t begin0-onlyvalues test-advanced-sequence + (t 'begin0-onlyvalues m:advanced (begin0 3 4 5) :: {(begin0 3 4 5)} -> {(begin0 3 5)} -> {3}) - (t begin0 test-advanced-sequence + (t 'begin0 m:advanced (begin0 (+ 3 4) (+ 4 5) (+ 6 7)) :: (begin0 {(+ 3 4)} (+ 4 5) (+ 6 7)) -> (begin0 {7} (+ 4 5) (+ 6 7)) @@ -1670,21 +1392,21 @@ ;; LAZY.SS: - (t lazy1 test-lazy-sequence + (t 'lazy1 m:lazy (! (+ 3 4)) :: 3 -> 3 :: 3 -> 3 :: 3 -> 3 :: {(! (+ 3 4))} -> {7}) - (t lazy2 test-lazy-sequence + (t 'lazy2 m:lazy (+ (+ 3 4) 5) :: (+ {(+ 3 4)} 5) -> (+ {7} 5) :: {(+ 7 5)} -> {12}) - (t lazy3 test-lazy-sequence + (t 'lazy3 m:lazy ((lambda (x y) (* x x)) (+ 1 2) (+ 3 4)) :: {((lambda (x y) (* x x)) (+ 1 2) (+ 3 4))} -> {(* (+ 1 2) (+ 1 2))} @@ -1694,7 +1416,7 @@ -> {9}) #; - (t1 teachpack-callbacks + (t1 'teachpack-callbacks (test-teachpack-sequence "(define (f2c x) x) (convert-gui f2c)" `() ; placeholder )) diff --git a/collects/tests/typed-scheme/fail/bad-map-poly.ss b/collects/tests/typed-scheme/fail/bad-map-poly.ss new file mode 100644 index 0000000000..280bd9bc54 --- /dev/null +++ b/collects/tests/typed-scheme/fail/bad-map-poly.ss @@ -0,0 +1,15 @@ +#; +(exn-pred exn:fail:contract? ".*interface for bad-map.*") +#lang scheme/load + +(module bad-map scheme + (provide bad-map) + (define (bad-map f l) + (list (f 'quux)))) + +(module use-bad-map typed-scheme + (require/typed 'bad-map + [bad-map (All (A B) ((A -> B) (Listof A) -> (Listof B)))]) + (bad-map add1 (list 12 13 14))) + +(require 'use-bad-map) diff --git a/collects/tests/typed-scheme/succeed/apply-dots-list.ss b/collects/tests/typed-scheme/succeed/apply-dots-list.ss new file mode 100644 index 0000000000..d068a14e5a --- /dev/null +++ b/collects/tests/typed-scheme/succeed/apply-dots-list.ss @@ -0,0 +1,25 @@ + +;; Change the lang to scheme for untyped version +#lang typed-scheme + +(define tests (list (list (λ() 1) 1 "test 1") + (list (λ() 2) 2 "test 2"))) + +; Comment out the type signature when running untyped +(: check-all (All (A ...) ((List (-> A) A String) ... A -> Void))) +(define (check-all . tests) + (let aux ([tests tests] + [num-passed 0]) + (if (null? tests) + (printf "~a tests passed.~n" num-passed) + (let ((test (car tests))) + (let ((actual ((car test))) + (expected (cadr test)) + (msg (caddr test))) + (if (equal? actual expected) + (aux (cdr tests) (+ num-passed 1)) + (printf "Test failed: ~a. Expected ~a, got ~a.~n" + msg expected actual))))))) + +(apply check-all tests) ; Works in untyped, but not in typed +(check-all (car tests) (cadr tests)) ; Works in typed or untyped \ No newline at end of file diff --git a/collects/tests/typed-scheme/succeed/no-bound-fl.ss b/collects/tests/typed-scheme/succeed/no-bound-fl.ss new file mode 100644 index 0000000000..1f9bd5265a --- /dev/null +++ b/collects/tests/typed-scheme/succeed/no-bound-fl.ss @@ -0,0 +1,11 @@ +#lang typed-scheme + +(: fold-left (All (a b ...) ((a b ... -> a) a (Listof b) ... -> a))) +(define (fold-left f a . bss) + (if (ormap null? bss) + a + (apply fold-left + f + (apply f a (map car bss)) + (map cdr bss)))) + diff --git a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss index e509fbb7dc..35b5561854 100644 --- a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss @@ -78,6 +78,10 @@ [(All (a ...) (a ... a -> Integer)) (-polydots (a) ( (list) (a a) . ->... . -Integer))] [(∀ (a) (Listof a)) (-poly (a) (make-Listof a))] [(∀ (a ...) (a ... a -> Integer)) (-polydots (a) ( (list) (a a) . ->... . -Integer))] + [(All (a ...) (a ... -> Number)) + (-polydots (a) ((list) [a a] . ->... . N))] + [(All (a ...) (values a ...)) + (-polydots (a) (make-ValuesDots (list) a 'a))] [(case-lambda (Number -> Boolean) (Number Number -> Number)) (cl-> [(N) B] [(N N) N])] [1 (-val 1)] @@ -89,6 +93,8 @@ [a (-v a) (extend-env (list 'a) (list (-v a)) initial-tvar-env)] + [(All (a ...) (a ... -> Number)) + (-polydots (a) ((list) [a a] . ->... . N))] )) diff --git a/collects/tests/web-server/private/request-test.ss b/collects/tests/web-server/private/request-test.ss index 2998634914..13f325a3f4 100644 --- a/collects/tests/web-server/private/request-test.ss +++ b/collects/tests/web-server/private/request-test.ss @@ -2,6 +2,7 @@ (require (planet schematics/schemeunit:3) web-server/private/connection-manager web-server/private/timer + web-server/http/request web-server/http) (provide request-tests) @@ -21,6 +22,7 @@ ip op (make-custodian) #f) headers))) + (define (get-bindings post-data) (define-values (conn headers) (make-mock-connection&headers post-data)) (call-with-values (lambda () (read-bindings&post-data/raw conn #"POST" #f headers)) @@ -54,6 +56,18 @@ ; XXX This needs to be really extensive, see what Apache has (test-suite "Parsing" + (test-suite + "URL Query" + (test-not-exn "Unfinished URL query" + (lambda () + (define ip (open-input-string "GET http://127.0.0.1:8080/servlets/examples/hello.ss?a=1&b: HTTP/1.1")) + (read-request + (make-connection 0 (make-timer ip +inf.0 (lambda () (void))) + ip + (open-output-bytes) (make-custodian) #f) + 8081 + (lambda _ (values "s1" "s2")))))) + (test-suite "POST Bindings" (test-equal? "simple test 1" diff --git a/collects/tests/xml/rss.xml b/collects/tests/xml/rss.xml new file mode 100644 index 0000000000..91ea38e1d0 --- /dev/null +++ b/collects/tests/xml/rss.xml @@ -0,0 +1,57 @@ + + + + + + XML.com + http://xml.com/pub + + XML.com features a rich mix of information and services + for the XML community. + + + + + + + + + + + + + + XML.com + http://www.xml.com + http://xml.com/universal/images/xml_tiny.gif + + + + Processing Inclusions with XSLT + http://xml.com/pub/2000/08/09/xslt/xslt.html + + Processing document inclusions with general XML tools can be + problematic. This article proposes a way of preserving inclusion + information through SAX-based processing. + + + + + Putting RDF to Work + http://xml.com/pub/2000/08/09/rdfdb/index.html + + Tool and API support for the Resource Description Framework + is slowly coming of age. Edd Dumbill takes a look at RDFDB, + one of the most exciting new RDF toolkits. + + + + + Search XML.com + Search XML.com's XML collection + s + http://search.xml.com + + \ No newline at end of file diff --git a/collects/tests/xml/xml-snip-bug.ss b/collects/tests/xml/xml-snip-bug.ss new file mode 100644 index 0000000000..943285eebf --- /dev/null +++ b/collects/tests/xml/xml-snip-bug.ss @@ -0,0 +1,3884 @@ +#reader(lib"read.ss""wxme")WXME0108 ## +#| + This file is in PLT Scheme editor format. + Open this file in DrScheme version 370 or later to read it. + + Most likely, it was created by saving a program in DrScheme, + and it probably contains a program with non-text elements + (such as images or comment boxes). + + http://www.plt-scheme.org +|# + 45 7 #"wxtext\0" +3 1 6 #"wxtab\0" +1 1 8 #"wxmedia\0" +4 1 8 #"wximage\0" +2 0 34 #"(lib \"syntax-browser.ss\" \"mrlib\")\0" +1 0 16 #"drscheme:number\0" +3 0 44 #"(lib \"number-snip.ss\" \"drscheme\" \"private\")\0" +1 0 36 #"(lib \"comment-snip.ss\" \"framework\")\0" +1 0 43 #"(lib \"collapsed-snipclass.ss\" \"framework\")\0" +0 0 19 #"drscheme:sexp-snip\0" +0 0 36 #"(lib \"cache-image-snip.ss\" \"mrlib\")\0" +1 0 33 #"(lib \"bullet-snip.ss\" \"browser\")\0" +0 0 29 #"drscheme:bindings-snipclass%\0" +1 0 25 #"(lib \"matrix.ss\" \"htdp\")\0" +1 0 22 #"drscheme:lambda-snip%\0" +1 0 8 #"gb:core\0" +5 0 10 #"gb:canvas\0" +5 0 17 #"gb:editor-canvas\0" +5 0 10 #"gb:slider\0" +5 0 9 #"gb:gauge\0" +5 0 11 #"gb:listbox\0" +5 0 12 #"gb:radiobox\0" +5 0 10 #"gb:choice\0" +5 0 8 #"gb:text\0" +5 0 11 #"gb:message\0" +5 0 10 #"gb:button\0" +5 0 12 #"gb:checkbox\0" +5 0 18 #"gb:vertical-panel\0" +5 0 9 #"gb:panel\0" +5 0 20 #"gb:horizontal-panel\0" +5 0 33 #"(lib \"readable.ss\" \"guibuilder\")\0" +1 0 56 +( + #"(lib \"hrule-snip.ss\" \"macro-debugger\" \"syntax-browse" + #"r\")\0" +) 1 0 18 #"java-comment-box%\0" +1 0 23 #"java-interactions-box%\0" +1 0 45 #"(lib \"image-snipr.ss\" \"slideshow\" \"private\")\0" +1 0 26 #"drscheme:pict-value-snip%\0" +0 0 38 #"(lib \"pict-snipclass.ss\" \"slideshow\")\0" +2 0 55 +( + #"(lib \"vertical-separator-snip.ss\" \"stepper\" \"private" + #"\")\0" +) 1 0 18 #"drscheme:xml-snip\0" +1 0 31 #"(lib \"xml-snipclass.ss\" \"xml\")\0" +1 0 21 #"drscheme:scheme-snip\0" +2 0 34 #"(lib \"scheme-snipclass.ss\" \"xml\")\0" +1 0 10 #"text-box%\0" +1 0 32 #"(lib \"text-snipclass.ss\" \"xml\")\0" +1 0 15 #"test-case-box%\0" +2 0 1 6 #"wxloc\0" +00000000000 1 1269 0 1 #"\0" +0 75 1 #"\0" +0 10 90 -1 90 -1 3 -1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 0 9 +#"Standard\0" +0 75 15 #"Lucida Console\0" +0 10 90 -1 90 -1 1 -1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 24 +#"framework:default-color\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 150 0 150 0 0 0 -1 -1 2 15 +#"text:ports out\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 150 0 150 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 15 +#"text:ports err\0" +0 -1 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 175 0 0 0 -1 -1 2 17 +#"text:ports value\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 175 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 27 +#"Matching Parenthesis Style\0" +0 -1 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 38 38 128 0 0 0 -1 -1 2 37 +#"framework:syntax-color:scheme:symbol\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 38 38 128 0 0 0 -1 -1 2 38 +#"framework:syntax-color:scheme:keyword\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 38 38 128 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 194 116 31 0 0 0 -1 -1 2 +38 #"framework:syntax-color:scheme:comment\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 194 116 31 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 41 128 38 0 0 0 -1 -1 2 37 +#"framework:syntax-color:scheme:string\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 41 128 38 0 0 0 -1 -1 2 39 +#"framework:syntax-color:scheme:constant\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 41 128 38 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 2 42 +#"framework:syntax-color:scheme:parenthesis\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 36 +#"framework:syntax-color:scheme:error\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 36 +#"framework:syntax-color:scheme:other\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 81 112 203 0 0 0 -1 -1 2 +38 #"drscheme:check-syntax:lexically-bound\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 81 112 203 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 68 0 203 0 0 0 -1 -1 2 31 +#"drscheme:check-syntax:imported\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 68 0 203 0 0 0 -1 -1 2 41 +#"profj:syntax-colors:scheme:block-comment\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 194 116 31 0 0 0 -1 -1 2 +35 #"profj:syntax-colors:scheme:keyword\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 139 0 139 0 0 0 -1 -1 2 37 +#"profj:syntax-colors:scheme:prim-type\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 139 0 139 0 0 0 -1 -1 2 38 +#"profj:syntax-colors:scheme:identifier\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 38 38 128 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 34 +#"profj:syntax-colors:scheme:string\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 35 +#"profj:syntax-colors:scheme:literal\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 35 +#"profj:syntax-colors:scheme:comment\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 194 116 31 0 0 0 -1 -1 2 +33 #"profj:syntax-colors:scheme:error\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 35 +#"profj:syntax-colors:scheme:default\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 37 +#"profj:syntax-colors:scheme:uncovered\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 35 +#"profj:syntax-colors:scheme:covered\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 139 0 139 0 0 0 -1 -1 4 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 4 4 +#"XML\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 8 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 8 24 +#"drscheme:text:ports err\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 4 1 +#"\0" +0 71 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 4 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 4 1 +#"\0" +0 71 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 4 1 +#"\0" +0 71 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 100 0 0 0 0 -1 -1 0 1 +#"\0" +0 75 1 #"\0" +0 12 90 -1 90 -1 3 -1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 0 1 +#"\0" +0 75 7 #"Monaco\0" +0 12 90 -1 90 -1 1 -1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 4 1 +#"\0" +0 -1 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 255 255 0 -1 -1 0 1 +#"\0" +0 75 15 #"Lucida Console\0" +0 10 90 -1 90 -1 1 -1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 0 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 200 0 0 0 0 0 -1 -1 22 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 14 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 4 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 20 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 15 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 17 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 22 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 165 0 0 0 0 -1 -1 14 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 165 0 0 0 0 -1 -1 4 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 165 0 0 0 0 -1 -1 15 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 165 0 0 0 0 -1 -1 17 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 165 0 0 0 0 -1 -1 20 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 165 0 0 0 0 -1 -1 26 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 19 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 19 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 165 0 0 0 0 -1 -1 22 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 14 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 4 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 19 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 17 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 15 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 20 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 26 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 65 105 225 0 0 0 -1 -1 26 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 165 0 0 0 0 -1 -1 24 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 24 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 165 0 0 0 0 -1 -1 24 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 2 +1 #"\0" +0 71 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 71 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 100 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 90 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 38 38 128 0 0 0 -1 -1 0 1 +#"\0" +0 75 23 #"Lucida Sans Typewriter\0" +0 12 90 -1 90 -1 1 -1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 2 +14 #"Html Standard\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 4 1 +#"\0" +0 71 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 148 0 211 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 4 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 100 0 0 0 0 -1 -1 0 1 +#"\0" +0 75 12 #"Courier New\0" +0 12 90 -1 90 -1 3 -1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 2 +40 #"framework:syntax-coloring:scheme:symbol\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 38 38 128 0 0 0 -1 -1 2 41 +#"framework:syntax-coloring:scheme:keyword\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 38 38 128 0 0 0 -1 -1 2 41 +#"framework:syntax-coloring:scheme:comment\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 194 116 31 0 0 0 -1 -1 2 +40 #"framework:syntax-coloring:scheme:string\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 41 128 38 0 0 0 -1 -1 2 42 +#"framework:syntax-coloring:scheme:constant\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 41 128 38 0 0 0 -1 -1 2 45 +#"framework:syntax-coloring:scheme:parenthesis\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 2 39 +#"framework:syntax-coloring:scheme:error\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 39 +#"framework:syntax-coloring:scheme:other\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 49 +#"drscheme:check-syntax:lexically-bound-identifier\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 81 112 203 0 0 0 -1 -1 2 +42 #"drscheme:check-syntax:imported-identifier\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 68 0 203 0 0 0 -1 -1 2 37 +#"profj:syntax-coloring:scheme:keyword\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 39 +#"profj:syntax-coloring:scheme:prim-type\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 139 0 139 0 0 0 -1 -1 2 40 +#"profj:syntax-coloring:scheme:identifier\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 38 38 128 0 0 0 -1 -1 2 36 +#"profj:syntax-coloring:scheme:string\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 37 +#"profj:syntax-coloring:scheme:literal\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 37 +#"profj:syntax-coloring:scheme:comment\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 194 116 31 0 0 0 -1 -1 2 +35 #"profj:syntax-coloring:scheme:error\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 37 +#"profj:syntax-coloring:scheme:default\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 39 +#"profj:syntax-coloring:scheme:uncovered\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 37 +#"profj:syntax-coloring:scheme:covered\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 139 0 139 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 255 255 0 0 0 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 128 106 255 0 0 0 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 119 255 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 47 208 28 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 65 209 60 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 203 91 55 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +0 15 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +2 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 -2 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 -2 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 50 205 50 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 -1 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 90 +1 #"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 -1 1 #"\0" +2 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +2 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +2 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 -1 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 153 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1.2 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 -1 1 #"\0" +1.2 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1.2 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 -1 1 #"\0" +1.2 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 0 -1 90 1 +#"\0" +0 70 1 #"\0" +0.6000000000000001 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 +0 0 0 -1 90 1 #"\0" +0 75 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +2 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 -1 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 -1 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 68 64 108 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 0 -1 2 +36 #"honu:syntax-coloring:scheme:keyword\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 40 +#"honu:syntax-coloring:scheme:parenthesis\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 2 35 +#"honu:syntax-coloring:scheme:string\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 36 +#"honu:syntax-coloring:scheme:literal\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 36 +#"honu:syntax-coloring:scheme:comment\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 194 116 31 0 0 0 -1 -1 2 +34 #"honu:syntax-coloring:scheme:error\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 39 +#"honu:syntax-coloring:scheme:identifier\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 38 38 128 0 0 0 -1 -1 2 36 +#"honu:syntax-coloring:scheme:default\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 0 -1 90 1 +#"\0" +0 70 1 #"\0" +0.75 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 2 +1 #"\0" +0 70 1 #"\0" +2 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 -2 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 -2 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 50 205 50 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 2 +1 #"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 0 -1 2 1 +#"\0" +0 70 1 #"\0" +0.6000000000000001 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 +0 0 0 -1 2 1 #"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 153 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 4 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 0 1 +#"\0" +0 75 8 #"Courier\0" +0 14 90 -1 90 -1 3 -1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 4 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 175 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 248 20 64 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 71 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 100 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 2 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 2 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 2 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 2 +1 #"\0" +0 70 1 #"\0" +2 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +2 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +0.75 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 94 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 200 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 80 80 248 0 0 0 -1 -1 2 1 +#"\0" +0 71 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 80 80 248 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 2 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 80 80 248 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 2 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 80 80 248 0 0 0 -1 -1 101 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 97 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 96 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 100 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 101 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 96 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 100 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 101 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 96 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 98 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 97 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 +100 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 2 +1 #"\0" +0 70 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 248 20 64 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1.2000000476837158 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 +0 -1 -1 2 1 #"\0" +0 70 1 #"\0" +1.2000000476837158 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 +0 0 -1 -1 2 1 #"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 68 64 108 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +0.800000011920929 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 +0 0 0 -1 2 1 #"\0" +0 70 1 #"\0" +0.6000000238418579 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 +0 0 0 -1 2 1 #"\0" +0 70 1 #"\0" +0.800000011920929 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 +0 1 -1 2 1 #"\0" +0 70 1 #"\0" +0.800000011920929 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 +0 1 -1 2 1 #"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 68 64 108 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 60 248 52 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Arial\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Arial\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Arial\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Arial\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 80 80 248 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Arial\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 80 80 248 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 153 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +0.800000011920929 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 68 64 108 +0 0 0 0 -1 2 1 #"\0" +0 70 1 #"\0" +0.800000011920929 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 +0 0 -1 2 1 #"\0" +0 75 1 #"\0" +0.800000011920929 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 +0 0 0 0 -1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 81 112 204 0 0 0 -1 -1 2 +47 #"drscheme:check-syntax:lexically-bound-variable\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 81 112 204 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 122 81 204 0 0 0 -1 -1 2 +40 #"drscheme:check-syntax:imported-variable\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 122 81 204 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 51 204 0 0 0 -1 -1 2 45 +#"drscheme:check-syntax:lexically-bound-syntax\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 51 204 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 68 0 204 0 0 0 -1 -1 2 38 +#"drscheme:check-syntax:imported-syntax\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 68 0 204 0 0 0 -1 -1 0 1 +#"\0" +0 75 8 #"Courier\0" +0 14 90 -1 90 -1 1 -1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 37 +#"syntax-coloring:Scheme Color:keyword\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 36 +#"syntax-coloring:Scheme Color:string\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 37 +#"syntax-coloring:Scheme Color:literal\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 105 105 105 0 0 0 -1 -1 2 +37 #"syntax-coloring:Scheme Color:comment\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 105 105 105 0 0 0 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 248 20 64 0 0 0 -1 -1 2 35 +#"syntax-coloring:Scheme Color:error\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 248 20 64 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 -1 -1 2 40 +#"syntax-coloring:Scheme Color:identifier\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 2 35 +#"syntax-coloring:Scheme Color:other\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 40 25 15 0 0 0 -1 -1 2 30 +#"drscheme:check-syntax:keyword\0" +0 -1 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 40 25 15 0 0 0 -1 -1 2 39 +#"drscheme:check-syntax:unbound-variable\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 248 20 64 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 -1 -1 2 37 +#"drscheme:check-syntax:bound-variable\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 -1 -1 2 32 +#"drscheme:check-syntax:primitive\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 51 135 39 0 0 0 -1 -1 2 31 +#"drscheme:check-syntax:constant\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 51 135 39 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 165 0 0 0 0 -1 -1 2 32 +#"drscheme:check-syntax:tail-call\0" +0 -1 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 165 0 0 0 0 -1 -1 2 27 +#"drscheme:check-syntax:base\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 2 29 +#"syntax-coloring:Java:keyword\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 0 100 0 0 0 0 -1 -1 2 28 +#"syntax-coloring:Java:string\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 0 100 0 0 0 0 -1 -1 2 29 +#"syntax-coloring:Java:literal\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 0 100 0 0 0 0 -1 -1 2 29 +#"syntax-coloring:Java:comment\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 105 105 105 0 0 0 -1 -1 2 +27 #"syntax-coloring:Java:error\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 248 20 64 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 0 0 139 0 0 0 -1 -1 2 32 +#"syntax-coloring:Java:identifier\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 0 0 139 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 169 169 169 0 0 0 -1 -1 2 +29 #"syntax-coloring:Java:default\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 169 169 169 0 0 0 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 40 25 15 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 165 0 0 0 0 -1 -1 0 1 +#"\0" +0 75 1 #"\0" +0 12 90 -1 90 -1 3 -1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 0 1 +#"\0" +0 75 8 #"Courier\0" +0 12 90 -1 90 -1 1 -1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 0 1 +#"\0" +0 75 12 #"Courier New\0" +0 12 90 90 90 90 3 3 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 40 25 15 0 0 0 1 1 2 1 #"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 248 20 64 0 0 0 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 51 135 39 0 0 0 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 0 1 #"\0" +0 75 8 #"Courier\0" +0 13 90 -1 90 -1 1 -1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 150 0 150 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 175 0 0 0 -1 -1 0 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 0 1 +#"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 1 1 0 13 +#"h-link-style\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 1 1 2 1 #"\0" +0 -1 1 #"\0" +1 2 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 2 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 80 80 248 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 2 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 80 80 248 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +1 321 326 1 #"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 326 1 +#"\0" +0 75 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 248 20 64 0 0 0 -1 -1 329 +1 #"\0" +1 321 2 1 #"\0" +0 -1 1 #"\0" +2 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 331 1 +#"\0" +1 321 332 1 #"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 332 1 +#"\0" +0 75 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 335 1 +#"\0" +1 321 2 1 #"\0" +0 -1 1 #"\0" +0.75 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 326 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 0 1 +#"\0" +0 75 1 #"\0" +0 12 90 90 90 90 3 3 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 1 2 1 +#"\0" +0 71 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 2 1 #"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 1 0 0 0 0 0 0 0 0 1 1 1 80 80 248 0 0 0 1 1 2 1 +#"\0" +0 71 1 #"\0" +1 0 90 90 90 90 3 3 1 0 0 0 0 0 0 0 0 1 1 1 80 80 248 0 0 0 1 1 2 1 +#"\0" +0 71 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 0 100 0 0 0 0 1 1 2 1 #"\0" +0 75 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 0 100 0 0 0 0 1 1 2 1 #"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 1 1 2 1 #"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 0 0 128 0 0 0 1 1 2 1 #"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 165 42 42 0 0 0 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 150 0 150 0 0 0 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 0 90 90 94 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 1 1 0 1 #"\0" +0 75 7 #"Monaco\0" +0 12 90 90 90 90 3 3 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 0 1 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 1 1 0 1 #"\0" +0 70 1 #"\0" +0 12 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 2 1 #"\0" +0 70 1 #"\0" +2 0 92 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 0 1 #"\0" +0 70 1 #"\0" +1 0 92 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 354 1 #"\0" +1 321 0 1 #"\0" +0 70 1 #"\0" +1 -2 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 356 1 #"\0" +1 321 355 1 #"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 50 205 50 0 0 0 1 1 0 1 +#"\0" +0 70 1 #"\0" +1 0 90 90 93 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 2 1 #"\0" +0 70 1 #"\0" +1 0 90 90 93 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 248 20 64 0 0 0 1 1 360 1 +#"\0" +1 321 353 1 #"\0" +1 321 362 1 #"\0" +0 75 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 362 1 #"\0" +0 75 1 #"\0" +1 0 92 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 2 1 #"\0" +0 70 1 #"\0" +1 0 90 90 93 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 326 1 #"\0" +0 70 1 #"\0" +1 0 90 90 93 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 2 1 #"\0" +0 75 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 1 1 2 1 +#"\0" +0 75 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 1 1 2 1 +#"\0" +0 75 1 #"\0" +1 0 92 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 153 0 0 0 0 0 1 1 2 1 #"\0" +0 75 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 2 1 #"\0" +0 75 1 #"\0" +1 0 92 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 2 1 #"\0" +0 70 1 #"\0" +1.5 0 92 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 373 1 +#"\0" +1 321 326 1 #"\0" +0 70 1 #"\0" +0.800000011920929 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 +0 1 326 1 #"\0" +0 70 1 #"\0" +0.6000000238418579 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 +0 1 2 1 #"\0" +0 70 1 #"\0" +1.2000000476837158 0 92 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 +1 1 377 1 #"\0" +1 321 2 1 #"\0" +0 75 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 1 1 2 1 +#"\0" +0 75 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 68 64 108 0 0 0 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 -2 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 0 1 #"\0" +0 75 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 1 1 0 1 +#"\0" +0 75 1 #"\0" +1 0 92 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 153 0 0 0 0 0 1 1 0 1 #"\0" +0 75 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 1 1 0 1 +#"\0" +0 70 1 #"\0" +1.2000000476837158 0 92 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 +1 1 385 1 #"\0" +1 321 0 1 #"\0" +1 321 0 1 #"\0" +0 70 1 #"\0" +1.5 0 92 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 388 1 +#"\0" +1 321 0 1 #"\0" +0 75 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 387 1 #"\0" +0 70 1 #"\0" +0.800000011920929 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 +0 1 387 1 #"\0" +0 70 1 #"\0" +0.6000000238418579 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 +0 1 387 1 #"\0" +0 70 1 #"\0" +1 0 90 90 93 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 0 1 #"\0" +0 70 1 #"\0" +1 0 90 90 93 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 248 20 64 0 0 0 1 1 394 1 +#"\0" +1 321 326 1 #"\0" +0 75 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 1 1 390 1 +#"\0" +1 321 397 1 #"\0" +0 75 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 1 1 387 1 +#"\0" +0 75 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 1 1 0 1 +#"\0" +0 75 7 #"Monaco\0" +0 10 90 90 90 90 3 3 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 0 0 175 0 0 0 1 1 0 1 #"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 2 1 #"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 200 0 0 0 0 0 1 1 2 1 #"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 60 248 52 0 0 0 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 -1 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 2 1 #"\0" +0 70 1 #"\0" +1 0 90 90 94 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 248 20 64 0 0 0 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 90 90 90 3 3 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 255 255 0 1 1 45 1 +#"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 45 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 0 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 178 34 34 255 255 255 -1 +-1 0 1 #"\0" +0 75 8 #"Courier\0" +0 14 90 -1 90 -1 1 -1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 255 165 0 0 0 0 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 -3 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 3 0 153 0 0 0 1 1 2 1 #"\0" +0 70 1 #"\0" +1 -3 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 102 102 102 0 0 0 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 80 80 248 0 0 0 1 1 0 1 +#"\0" +0 75 12 #"Courier New\0" +0 12 90 -1 90 -1 3 -1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 2 1 +#"\0" +0 75 1 #"\0" +1 0 90 90 90 90 3 3 1 0 0 0 0 0 0 0 0 1 1 1 80 80 248 0 0 0 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 160 32 240 0 0 0 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 90 90 90 3 3 1 0 0 0 0 0 0 0 0 1 1 1 248 20 64 0 0 0 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 80 80 248 0 0 0 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 -1 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 -1 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 153 0 0 0 0 0 -1 -1 0 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 1 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 -1 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 -1 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 80 80 248 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Arial\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 60 248 52 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 255 255 0 -1 -1 101 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 96 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 99 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 101 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 97 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 96 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 100 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 0 1 +#"\0" +0 75 8 #"Courier\0" +0 13 90 -1 90 -1 1 -1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 2 1 +#"\0" +0 75 1 #"\0" +0.800000011920929 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 36 36 140 +0 0 0 1 -1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 69 0 255 69 0 -1 -1 2 +1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 99 71 255 99 71 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 139 0 0 139 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 248 20 64 248 20 64 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 178 34 34 178 34 34 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 220 20 60 220 20 60 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 20 147 255 20 147 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 176 48 96 176 48 96 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 205 92 92 205 92 92 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 199 21 133 199 21 133 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 208 32 144 208 32 144 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 240 128 128 240 128 128 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 105 180 255 105 180 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 219 112 147 219 112 147 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 182 193 255 182 193 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 188 143 143 188 143 143 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 192 203 255 192 203 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 218 112 214 218 112 214 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 240 245 255 240 245 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 250 250 255 250 250 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 210 105 30 210 105 30 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 139 69 19 139 69 19 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 132 60 36 132 60 36 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 140 0 255 140 0 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 127 80 255 127 80 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 160 82 45 160 82 45 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 165 0 255 165 0 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 250 128 114 250 128 114 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 205 133 63 205 133 63 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 184 134 11 184 134 11 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 218 165 32 218 165 32 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 244 164 96 244 164 96 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 160 122 255 160 122 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 233 150 122 233 150 122 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 215 0 255 215 0 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 255 0 255 255 0 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 128 128 0 128 128 0 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 222 184 135 222 184 135 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 210 180 140 210 180 140 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 222 173 255 222 173 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 218 185 255 218 185 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 240 230 140 240 230 140 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 189 183 107 189 183 107 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 228 181 255 228 181 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 245 222 179 245 222 179 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 228 196 255 228 196 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 238 232 170 238 232 170 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 235 205 255 235 205 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 234 234 173 234 234 173 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 239 213 255 239 213 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 228 225 255 228 225 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 250 205 255 250 205 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 250 235 215 250 235 215 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 248 220 255 248 220 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 250 250 210 250 250 210 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 253 245 230 253 245 230 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 250 240 230 250 240 230 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 255 224 255 255 224 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 245 238 255 245 238 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 245 245 220 245 245 220 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 250 240 255 250 240 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 255 240 255 255 240 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 60 248 52 60 248 52 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 124 252 0 124 252 0 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 127 255 0 127 255 0 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 173 255 47 173 255 47 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 154 205 50 154 205 50 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 107 142 35 107 142 35 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 85 107 47 85 107 47 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 143 188 139 143 188 139 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 255 0 0 255 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 100 0 0 100 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 50 205 50 50 205 50 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 34 139 34 34 139 34 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 255 127 0 255 127 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 250 154 0 250 154 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 46 139 87 46 139 87 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 60 179 113 60 179 113 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 112 216 144 112 216 144 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 144 238 144 144 238 144 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 152 251 152 152 251 152 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 102 205 170 102 205 170 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 64 224 208 64 224 208 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 32 178 170 32 178 170 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 72 209 204 72 209 204 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 240 255 240 240 255 240 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 245 255 250 245 255 250 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 65 105 225 65 105 225 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 30 144 255 30 144 255 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 191 255 0 191 255 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 100 149 237 100 149 237 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 70 130 180 70 130 180 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 135 206 250 135 206 250 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 206 209 0 206 209 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 255 255 0 255 255 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 139 139 0 139 139 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 128 128 0 128 128 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 135 206 235 135 206 235 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 95 158 160 95 158 160 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 47 79 79 47 79 79 -1 -1 2 +1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 119 136 153 119 136 153 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 112 128 144 112 128 144 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 176 196 222 176 196 222 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 173 216 230 173 216 230 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 176 224 230 176 224 230 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 175 238 238 175 238 238 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 224 255 255 224 255 255 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 240 248 255 240 248 255 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 240 255 255 240 255 255 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 205 0 0 205 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 139 0 0 139 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 25 25 112 25 25 112 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 36 36 140 36 36 140 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 80 80 248 80 80 248 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 75 0 130 75 0 130 -1 -1 2 +1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 138 43 226 138 43 226 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 123 104 238 123 104 238 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 106 90 205 106 90 205 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 160 32 240 160 32 240 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 72 61 139 72 61 139 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 148 0 211 148 0 211 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 153 50 204 153 50 204 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 147 112 219 147 112 219 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 186 85 211 186 85 211 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 0 255 255 0 255 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 139 0 139 139 0 139 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 238 130 238 238 130 238 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 221 160 221 221 160 221 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 230 230 250 230 230 250 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 216 191 216 216 191 216 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 248 248 255 248 248 255 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 255 255 255 255 255 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 245 245 245 245 245 245 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 220 220 220 220 220 220 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 211 211 211 211 211 211 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 192 192 192 192 192 192 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 190 190 190 190 190 190 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 169 169 169 169 169 169 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 105 105 105 105 105 105 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 -1 -1 0 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 0 -1 2 1 #"\0" +0 75 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 248 20 64 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 -2 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 4 1 +#"\0" +0 70 1 #"\0" +0 12 90 -1 90 -1 3 -1 0 1 0 1 0 0 0 0 0 0 0 0 150 0 150 255 255 255 1 -1 +2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 255 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 16 #"Times New Roman\0" +1 1 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Courier New\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Courier New\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Courier New\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 0 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 2 -1 0 1 #"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 2 -1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 1 1 1 1 0 0 0 0 0 0 248 248 250 -1 -1 2 +1 #"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 1 1 1 1 0 0 0 0 0 0 248 248 250 -1 -1 2 +1 #"\0" +0 70 1 #"\0" +1 3 -1 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 102 153 248 248 250 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 1 0 0 0 0 0 0 0 0 255 248 248 250 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 3 -1 -1 -1 -1 -1 -1 1 0 0 0 0 1 0 0 0 0 0 0 0 0 255 248 248 250 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 4 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 4 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 4 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 178 34 34 255 255 255 -1 +-1 97 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 0 -1 2 1 +#"\0" +0 70 1 #"\0" +1.2 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1.2 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 99 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 102 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 99 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 2 +1 #"\0" +0 70 7 #"Geneva\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Geneva\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Geneva\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Monaco\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Monaco\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Monaco\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Times\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Times\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Times\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Helvetica\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Helvetica\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Helvetica\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Courier\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Courier\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Courier\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Symbol\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Symbol\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Symbol\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #".Keyboard\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #".Keyboard\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #".Keyboard\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #".LastResort\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #".LastResort\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #".LastResort\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 14 #"Lucida Grande\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 14 #"Lucida Grande\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 14 #"Lucida Grande\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 14 #"Zapf Dingbats\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 14 #"Zapf Dingbats\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 14 #"Zapf Dingbats\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 21 #".TimesLTMM_1_Wt_1_Wd\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 21 #".TimesLTMM_1_Wt_1_Wd\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 21 #".TimesLTMM_1_Wt_1_Wd\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 #".HelveLTMM_170_Wt_1200_Wd\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 #".HelveLTMM_170_Wt_1200_Wd\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 #".HelveLTMM_170_Wt_1200_Wd\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Osaka\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Osaka\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Osaka\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"Osaka\342\210\222\347\255\211\345\271\205\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"Osaka\342\210\222\347\255\211\345\271\205\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"Osaka\342\210\222\347\255\211\345\271\205\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 22 #"Apple LiGothic Medium\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 22 #"Apple LiGothic Medium\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 22 #"Apple LiGothic Medium\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"AppleGothic\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"AppleGothic\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"AppleGothic\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Monaco CY\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Monaco CY\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Monaco CY\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 17 #"Lucida Grande CY\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 17 #"Lucida Grande CY\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 17 #"Lucida Grande CY\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 9 #"Times CY\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 9 #"Times CY\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 9 #"Times CY\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 4 #"Hei\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 4 #"Hei\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 4 #"Hei\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Geneva CE\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Geneva CE\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Geneva CE\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Monaco CE\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Monaco CE\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Monaco CE\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 9 #"Times CE\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 9 #"Times CE\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 9 #"Times CE\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"Helvetica CE\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"Helvetica CE\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"Helvetica CE\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"Courier CE\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"Courier CE\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"Courier CE\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\350\247\222\343" + #"\202\264 Pro W6\0" +) 0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\350\247\222\343" + #"\202\264 Pro W6\0" +) 0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\350\247\222\343" + #"\202\264 Pro W6\0" +) 0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\350\247\222\343" + #"\202\264 Pro W3\0" +) 0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\350\247\222\343" + #"\202\264 Pro W3\0" +) 0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\350\247\222\343" + #"\202\264 Pro W3\0" +) 0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\344\270\270\343" + #"\202\264 Pro W4\0" +) 0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\344\270\270\343" + #"\202\264 Pro W4\0" +) 0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\344\270\270\343" + #"\202\264 Pro W4\0" +) 0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\346\230\216\346" + #"\234\235 Pro W6\0" +) 0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\346\230\216\346" + #"\234\235 Pro W6\0" +) 0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\346\230\216\346" + #"\234\235 Pro W6\0" +) 0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\346\230\216\346" + #"\234\235 Pro W3\0" +) 0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\346\230\216\346" + #"\234\235 Pro W3\0" +) 0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\346\230\216\346" + #"\234\235 Pro W3\0" +) 0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #".Aqua \343\201\213\343\201\252\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #".Aqua \343\201\213\343\201\252\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #".Aqua \343\201\213\343\201\252\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"\345\215\216\346\226\207\347\273\206\351\273\221\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"\345\215\216\346\226\207\347\273\206\351\273\221\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"\345\215\216\346\226\207\347\273\206\351\273\221\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\350\247\222\343" + #"\202\264 Std W8\0" +) 0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\350\247\222\343" + #"\202\264 Std W8\0" +) 0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\350\247\222\343" + #"\202\264 Std W8\0" +) 0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"Geeza Pro Bold\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"Geeza Pro Bold\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"Geeza Pro Bold\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 17 #"Lucida Grande CE\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 17 #"Lucida Grande CE\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 17 #"Lucida Grande CE\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"\345\204\267\351\273\221 Pro\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"\345\204\267\351\273\221 Pro\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"\345\204\267\351\273\221 Pro\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Geeza Pro\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Geeza Pro\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Geeza Pro\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #".Aqua \343\201\213\343\201\252 \343\203\234\343\203\274\343\203\253" + #"\343\203\211\0" +) 0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #".Aqua \343\201\213\343\201\252 \343\203\234\343\203\274\343\203\253" + #"\343\203\211\0" +) 0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #".Aqua \343\201\213\343\201\252 \343\203\234\343\203\274\343\203\253" + #"\343\203\211\0" +) 0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"\345\215\216\346\226\207\351\273\221\344\275\223\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"\345\215\216\346\226\207\351\273\221\344\275\223\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"\345\215\216\346\226\207\351\273\221\344\275\223\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Zapfino\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Zapfino\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Zapfino\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"Trebuchet MS\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"Trebuchet MS\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"Trebuchet MS\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"Arial Narrow\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"Arial Narrow\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"Arial Narrow\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Arial\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Arial\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Arial\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Courier New\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Courier New\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Courier New\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 16 #"Times New Roman\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 16 #"Times New Roman\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 16 #"Times New Roman\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"Hoefler Text\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"Hoefler Text\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"Hoefler Text\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 23 #"Hoefler Text Ornaments\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 23 #"Hoefler Text Ornaments\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 23 #"Hoefler Text Ornaments\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Marker Felt\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Marker Felt\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Marker Felt\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Impact\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Impact\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Impact\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 5 #"Skia\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 5 #"Skia\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 5 #"Skia\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Copperplate\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Copperplate\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Copperplate\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"Apple Chancery\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"Apple Chancery\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"Apple Chancery\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 18 #"Copperplate Light\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 18 #"Copperplate Light\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 18 #"Copperplate Light\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Baskerville\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Baskerville\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Baskerville\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 21 #"Baskerville Semibold\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 21 #"Baskerville Semibold\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 21 #"Baskerville Semibold\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"Big Caslon\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"Big Caslon\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"Big Caslon\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 22 #"Arial Rounded MT Bold\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 22 #"Arial Rounded MT Bold\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 22 #"Arial Rounded MT Bold\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 16 #"Brush Script MT\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 16 #"Brush Script MT\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 16 #"Brush Script MT\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 20 #"American Typewriter\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 20 #"American Typewriter\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 20 #"American Typewriter\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 30 #"American Typewriter Condensed\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 30 #"American Typewriter Condensed\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 30 #"American Typewriter Condensed\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 #"American Typewriter Light\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 #"American Typewriter Light\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 #"American Typewriter Light\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 36 #"American Typewriter Condensed Light\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 36 #"American Typewriter Condensed Light\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 36 #"American Typewriter Condensed Light\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Futura\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Futura\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Futura\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 17 #"Futura Condensed\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 17 #"Futura Condensed\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 17 #"Futura Condensed\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 18 #"Optima ExtraBlack\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 18 #"Optima ExtraBlack\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 18 #"Optima ExtraBlack\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"Herculanum\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"Herculanum\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"Herculanum\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Gill Sans\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Gill Sans\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Gill Sans\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 16 #"Gill Sans Light\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 16 #"Gill Sans Light\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 16 #"Gill Sans Light\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 14 #"Comic Sans MS\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 14 #"Comic Sans MS\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 14 #"Comic Sans MS\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"Helvetica Neue\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"Helvetica Neue\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"Helvetica Neue\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 30 #"Helvetica Neue Bold Condensed\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 30 #"Helvetica Neue Bold Condensed\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 30 #"Helvetica Neue Bold Condensed\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 #"Helvetica Neue UltraLight\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 #"Helvetica Neue UltraLight\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 #"Helvetica Neue UltraLight\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 21 #"Helvetica Neue Light\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 21 #"Helvetica Neue Light\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 21 #"Helvetica Neue Light\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 31 #"Helvetica Neue Black Condensed\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 31 #"Helvetica Neue Black Condensed\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 31 #"Helvetica Neue Black Condensed\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Papyrus\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Papyrus\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Papyrus\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Optima\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Optima\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Optima\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Andale Mono\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Andale Mono\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Andale Mono\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Verdana\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Verdana\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Verdana\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Didot\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Didot\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Didot\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Arial Black\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Arial Black\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Arial Black\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Georgia\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Georgia\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Georgia\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 9 #"Webdings\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 9 #"Webdings\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 9 #"Webdings\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Cochin\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Cochin\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Cochin\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"BiauKai\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"BiauKai\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"BiauKai\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 19 #"Apple LiSung Light\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 19 #"Apple LiSung Light\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 19 #"Apple LiSung Light\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"AppleMyungjo\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"AppleMyungjo\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"AppleMyungjo\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"#\352\266\201\354\204\234\354\262\264\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"#\352\266\201\354\204\234\354\262\264\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"#\352\266\201\354\204\234\354\262\264\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"#\355\227\244\353\223\234\353\235\274\354\235\270A\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"#\355\227\244\353\223\234\353\235\274\354\235\270A\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"#\355\227\244\353\223\234\353\235\274\354\235\270A\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"#\355\225\204\352\270\260\354\262\264\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"#\355\225\204\352\270\260\354\262\264\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"#\355\225\204\352\270\260\354\262\264\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"#PC\353\252\205\354\241\260\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"#PC\353\252\205\354\241\260\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"#PC\353\252\205\354\241\260\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Geneva CY\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Geneva CY\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Geneva CY\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Charcoal CY\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Charcoal CY\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Charcoal CY\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"Helvetica CY\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"Helvetica CY\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"Helvetica CY\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 4 #"Kai\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 4 #"Kai\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 4 #"Kai\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"\345\215\216\346\226\207\345\256\213\344\275\223\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"\345\215\216\346\226\207\345\256\213\344\275\223\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"\345\215\216\346\226\207\345\256\213\344\275\223\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"Chalkboard\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"Chalkboard\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"Chalkboard\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 21 #"Euphemia UCAS Italic\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 21 #"Euphemia UCAS Italic\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 21 #"Euphemia UCAS Italic\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"\345\204\267\345\256\213 Pro\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"\345\204\267\345\256\213 Pro\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"\345\204\267\345\256\213 Pro\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 9 #"Ayuthaya\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 9 #"Ayuthaya\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 9 #"Ayuthaya\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 9 #"Thonburi\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 9 #"Thonburi\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 9 #"Thonburi\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"\345\215\216\346\226\207\346\245\267\344\275\223\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"\345\215\216\346\226\207\346\245\267\344\275\223\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"\345\215\216\346\226\207\346\245\267\344\275\223\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 19 #"Euphemia UCAS Bold\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 19 #"Euphemia UCAS Bold\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 19 #"Euphemia UCAS Bold\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"InaiMathi\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"InaiMathi\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"InaiMathi\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 14 #"Euphemia UCAS\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 14 #"Euphemia UCAS\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 14 #"Euphemia UCAS\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 16 #"Chalkboard Bold\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 16 #"Chalkboard Bold\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 16 #"Chalkboard Bold\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Silom\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Silom\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Silom\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"\345\215\216\346\226\207\344\273\277\345\256\213\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"\345\215\216\346\226\207\344\273\277\345\256\213\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"\345\215\216\346\226\207\344\273\277\345\256\213\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"GB18030 Bitmap\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"GB18030 Bitmap\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"GB18030 Bitmap\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Krungthep\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Krungthep\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Krungthep\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Sathu\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Sathu\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Sathu\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 21 #"Plantagenet Cherokee\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 21 #"Plantagenet Cherokee\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 21 #"Plantagenet Cherokee\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +0.8 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 2 1 +#"\0" +0 70 1 #"\0" +0.8 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 2 1 +#"\0" +0 70 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 2 1 +#"\0" +0 75 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 2 1 +#"\0" +0 70 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 0 -1 2 1 +#"\0" +0 75 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 0 -1 0 1 +#"\0" +0 70 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 0 -1 0 1 +#"\0" +0 75 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 0 -1 0 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 2 -1 0 1 #"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 2 -1 0 1 #"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 2 -1 0 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 2 -1 0 1 #"\0" +0 75 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 2 -1 0 1 #"\0" +0 75 1 #"\0" +0.8 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 0 1 +#"\0" +0 70 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 0 1 +#"\0" +0 70 1 #"\0" +0.8 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 0 -1 0 1 +#"\0" +0 70 1 #"\0" +0.6400000000000001 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 +0 1 -1 0 1 #"\0" +0 75 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 0 1 +#"\0" +0 70 1 #"\0" +0.8 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 0 1 +#"\0" +0 70 1 #"\0" +1.2 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 2 -1 0 1 +#"\0" +0 70 1 #"\0" +1.2 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 2 -1 0 1 +#"\0" +0 70 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 2 -1 0 1 +#"\0" +0 70 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 2 -1 0 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 2 -1 2 1 #"\0" +0 75 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 102 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 98 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 98 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 102 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 0 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 94 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 0 -1 2 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 98 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 178 34 34 255 255 255 -1 +-1 90 1 #"\0" +0 75 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 96 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 178 34 34 255 255 255 -1 +-1 0 1 #"\0" +0 75 12 #"Courier New\0" +0 10 90 -1 90 -1 3 -1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 102 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 178 34 34 255 255 255 -1 +-1 99 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 153 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 0 1 +#"\0" +0 75 12 #"Courier New\0" +0 7 90 -1 90 -1 3 -1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 160 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 92 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 160 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 92 -1 90 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 90 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 90 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 160 0 0 0 0 -1 -1 90 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 2 -1 90 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 99 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 178 34 34 255 255 255 -1 +-1 100 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 178 34 34 255 255 255 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 90 1 +#"\0" +0 70 1 #"\0" +0.8 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 68 64 108 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 1 -1 90 +1 #"\0" +0 75 1 #"\0" +0.8 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 2 -1 4 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 255 0 0 0 0 -1 -1 0 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 255 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 2 -1 90 1 +#"\0" +0 70 1 #"\0" +1 -1 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 -1 1 #"\0" +1 -1 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 -1 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 4 1 +#"\0" +0 71 1 #"\0" +1 0 -1 -1 94 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +2 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1.2 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 90 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +0.8 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 100 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 90 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 64 128 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 255 0 0 0 0 -1 -1 0 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 255 0 0 0 0 2 -1 2 1 +#"\0" +0 70 6 #"Arial\0" +0.75 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 2 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 1 -1 2 1 +#"\0" +0 75 1 #"\0" +0.8 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 1 -1 19 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 92 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 69 0 255 69 0 -1 -1 90 +1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 99 71 255 99 71 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 139 0 0 139 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 0 0 255 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 178 34 34 178 34 34 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 220 20 60 220 20 60 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 20 147 255 20 147 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 176 48 96 176 48 96 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 205 92 92 205 92 92 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 199 21 133 199 21 133 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 208 32 144 208 32 144 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 240 128 128 240 128 128 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 105 180 255 105 180 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 219 112 147 219 112 147 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 182 193 255 182 193 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 188 143 143 188 143 143 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 192 203 255 192 203 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 218 112 214 218 112 214 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 240 245 255 240 245 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 250 250 255 250 250 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 210 105 30 210 105 30 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 139 69 19 139 69 19 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 132 60 36 132 60 36 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 140 0 255 140 0 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 127 80 255 127 80 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 160 82 45 160 82 45 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 165 0 255 165 0 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 250 128 114 250 128 114 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 205 133 63 205 133 63 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 184 134 11 184 134 11 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 218 165 32 218 165 32 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 244 164 96 244 164 96 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 160 122 255 160 122 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 233 150 122 233 150 122 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 215 0 255 215 0 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 255 0 255 255 0 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 128 128 0 128 128 0 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 222 184 135 222 184 135 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 210 180 140 210 180 140 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 222 173 255 222 173 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 218 185 255 218 185 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 240 230 140 240 230 140 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 189 183 107 189 183 107 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 228 181 255 228 181 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 245 222 179 245 222 179 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 228 196 255 228 196 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 238 232 170 238 232 170 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 235 205 255 235 205 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 234 234 173 234 234 173 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 239 213 255 239 213 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 228 225 255 228 225 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 250 205 255 250 205 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 250 235 215 250 235 215 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 248 220 255 248 220 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 250 250 210 250 250 210 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 253 245 230 253 245 230 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 250 240 230 250 240 230 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 255 224 255 255 224 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 245 238 255 245 238 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 245 245 220 245 245 220 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 250 240 255 250 240 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 255 240 255 255 240 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 255 0 0 255 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 124 252 0 124 252 0 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 127 255 0 127 255 0 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 173 255 47 173 255 47 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 154 205 50 154 205 50 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 107 142 35 107 142 35 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 85 107 47 85 107 47 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 143 188 139 143 188 139 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 100 0 0 100 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 50 205 50 50 205 50 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 34 139 34 34 139 34 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 255 127 0 255 127 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 250 154 0 250 154 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 46 139 87 46 139 87 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 60 179 113 60 179 113 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 112 216 144 112 216 144 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 144 238 144 144 238 144 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 152 251 152 152 251 152 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 102 205 170 102 205 170 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 64 224 208 64 224 208 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 32 178 170 32 178 170 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 72 209 204 72 209 204 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 240 255 240 240 255 240 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 245 255 250 245 255 250 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 65 105 225 65 105 225 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 30 144 255 30 144 255 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 191 255 0 191 255 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 100 149 237 100 149 237 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 70 130 180 70 130 180 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 135 206 250 135 206 250 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 206 209 0 206 209 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 255 255 0 255 255 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 139 139 0 139 139 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 128 128 0 128 128 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 135 206 235 135 206 235 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 95 158 160 95 158 160 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 47 79 79 47 79 79 -1 -1 90 +1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 119 136 153 119 136 153 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 112 128 144 112 128 144 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 176 196 222 176 196 222 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 173 216 230 173 216 230 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 176 224 230 176 224 230 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 175 238 238 175 238 238 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 224 255 255 224 255 255 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 240 248 255 240 248 255 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 240 255 255 240 255 255 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 205 0 0 205 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 139 0 0 139 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 25 25 112 25 25 112 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 36 36 140 36 36 140 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 255 0 0 255 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 75 0 130 75 0 130 -1 -1 90 +1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 138 43 226 138 43 226 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 123 104 238 123 104 238 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 106 90 205 106 90 205 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 160 32 240 160 32 240 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 72 61 139 72 61 139 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 148 0 211 148 0 211 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 153 50 204 153 50 204 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 147 112 219 147 112 219 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 186 85 211 186 85 211 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 0 255 255 0 255 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 139 0 139 139 0 139 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 238 130 238 238 130 238 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 221 160 221 221 160 221 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 230 230 250 230 230 250 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 216 191 216 216 191 216 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 248 248 255 248 248 255 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 255 255 255 255 255 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 245 245 245 245 245 245 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 220 220 220 220 220 220 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 211 211 211 211 211 211 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 192 192 192 192 192 192 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 190 190 190 190 190 190 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 169 169 169 169 169 169 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 105 105 105 105 105 105 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 0 0 0 255 228 225 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 0 0 0 224 255 255 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 0 0 255 255 255 255 -1 -1 +2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 0 0 255 224 255 255 -1 -1 +2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 0 0 0 245 245 245 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 107 142 35 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 107 142 35 255 255 255 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 107 142 35 224 255 255 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 139 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 139 0 0 255 255 255 -1 -1 +2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 139 0 0 224 255 255 -1 -1 +2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 139 0 0 255 228 225 -1 -1 +2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 70 130 180 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 70 130 180 255 255 255 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 70 130 180 224 255 255 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 70 130 180 255 228 225 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 47 79 79 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 47 79 79 255 255 255 -1 -1 +2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 47 79 79 224 255 255 -1 -1 +2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 47 79 79 255 228 225 -1 -1 +2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 139 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 0 0 139 255 255 255 -1 -1 +2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 0 0 139 224 255 255 -1 -1 +2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 47 79 79 245 245 245 -1 -1 +2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 160 32 240 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 160 32 240 255 255 255 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 160 32 240 224 255 255 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 255 165 0 255 255 255 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 255 165 0 224 255 255 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 250 128 114 0 0 0 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 250 128 114 255 255 255 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 250 128 114 224 255 255 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 250 128 114 245 245 245 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 250 128 114 255 228 225 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 184 134 11 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 184 134 11 255 255 255 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 184 134 11 224 255 255 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 184 134 11 245 245 245 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 184 134 11 255 228 225 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 128 128 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 128 128 0 255 255 255 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 128 128 0 224 255 255 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 169 169 169 0 0 0 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 169 169 169 255 255 255 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 169 169 169 224 255 255 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 169 169 169 255 228 225 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 169 169 169 245 245 245 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 192 46 214 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 90 -1 94 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 94 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 57 89 216 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 90 -1 -1 94 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 102 102 255 0 0 0 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 94 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 102 102 255 0 0 0 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 94 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 249 148 40 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 51 174 51 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 60 194 57 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 94 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 151 69 43 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 94 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 50 163 255 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 94 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 166 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 94 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 175 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 94 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 38 38 128 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 94 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 38 38 128 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 94 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 194 116 31 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 94 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 94 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 81 112 203 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 94 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 68 0 203 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 1 1 1 1 0 0 0 0 0 0 255 255 255 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 255 228 225 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 0 0 255 255 255 -1 -1 +2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 255 255 255 255 -1 -1 +2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 0 0 224 255 255 -1 -1 +2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 224 255 255 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 255 224 255 255 -1 -1 +2 1 #"\0" +0 70 8 #"Courier\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Courier\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Courier\0" +1 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 192 192 192 0 0 0 -1 -1 2 +1 #"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 192 192 192 0 0 0 -1 -1 22 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 14 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 22 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 14 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 20 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 22 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 15 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 14 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 20 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 4 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 +00000000002 0 00000000000 39 00000000000 19 0 26 3 16 +#"#lang scheme/gui" +0 0 4 29 1 #"\n" +0 0 4 29 1 #"\n" +0 0 22 3 1 #"(" +0 0 15 3 6 #"define" +0 0 4 3 1 #" " +0 0 22 3 1 #"(" +0 0 14 3 11 #"single-line" +0 0 4 3 1 #" " +0 0 14 3 4 #"name" +0 0 4 3 1 #" " +0 0 14 3 4 #"link" +0 0 22 3 1 #")" +0 0 4 29 1 #"\n" +0 0 4 3 2 #" " +0 39 00000000060 4 0 00000000000 1 00000000001 41 00000000000 5 0 45 3 8 +#"" +0 41 00000000014 45 1 00000000000 1 00000000000 1 0 14 3 4 #"name" +0 00000000000 0 0 45 3 4 #"" +0 00000000000 0 0 22 3 1 #")" +0 0 4 29 1 #"\n" +0 0 4 29 1 #"\n" +0 00000000000 diff --git a/collects/texpict/utils.ss b/collects/texpict/utils.ss index 71ef173391..d353a200a6 100644 --- a/collects/texpict/utils.ss +++ b/collects/texpict/utils.ss @@ -56,19 +56,25 @@ clip hyperlinkize) + + (define (pict-path? p) + (or (pict? p) + (and (pair? p) + (list? p) + (andmap pict? p)))) (provide/contract [pin-line (->* (pict? - pict? (-> pict? pict? (values number? number?)) - pict? (-> pict? pict? (values number? number?))) + pict-path? (-> pict? pict-path? (values number? number?)) + pict-path? (-> pict? pict-path? (values number? number?))) ((or/c false/c number?) (or/c false/c string?) boolean?) pict?)] [pin-arrow-line (->* (number? pict? - pict? (-> pict? pict? (values number? number?)) - pict? (-> pict? pict? (values number? number?))) + pict-path? (-> pict? pict-path? (values number? number?)) + pict-path? (-> pict? pict-path? (values number? number?))) ((or/c false/c number?) (or/c false/c string?) boolean? @@ -76,8 +82,8 @@ #:hide-arrowhead? any/c) pict?)] [pin-arrows-line (->* (number? pict? - pict? (-> pict? pict? (values number? number?)) - pict? (-> pict? pict? (values number? number?))) + pict-path? (-> pict? pict-path? (values number? number?)) + pict-path? (-> pict? pict-path? (values number? number?))) ((or/c false/c number?) (or/c false/c string?) boolean? diff --git a/collects/typed/file/tar.ss b/collects/typed/file/tar.ss new file mode 100644 index 0000000000..625a45a899 --- /dev/null +++ b/collects/typed/file/tar.ss @@ -0,0 +1,22 @@ +#lang typed-scheme +;; typed-scheme wrapper on file/tar +;; yc 2009/2/25 + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; basic type aliases. +(define-type-alias Path-String (U Path String)) + +(require/typed file/tar + ;; tar appears to return exact-nonenegative-integer? instead of void? + [tar (Path-String Path-String * -> Integer)] + ;; tar->output appears to take (listof path) instead of (listof path-string?) + ;; it also appears to return exact-nonenegative-integer? + [tar->output (case-lambda ((Listof Path) -> Integer) + ((Listof Path) Output-Port -> Integer))] + ;; tar->gzip + ;; missing from file/tar but available in mzlib/tar + ;; actually returns void? + [tar-gzip (Path-String Path-String * -> Void)] + ) + +(provide tar tar->output tar-gzip) \ No newline at end of file diff --git a/collects/typed/srfi/14.ss b/collects/typed/srfi/14.ss index 4867007896..4c656e913a 100644 --- a/collects/typed/srfi/14.ss +++ b/collects/typed/srfi/14.ss @@ -91,23 +91,28 @@ [char-set:ascii Char-Set] [char-set:empty Char-Set] [char-set:full Char-Set] + [char-set-fold (All (A) ((Char A -> A) A Char-Set -> A))] + [char-set-unfold + (All (A) + (case-lambda + ((A -> Any) (A -> Char) (A -> A) A -> Char-Set) + ((A -> Any) (A -> Char) (A -> A) A Char-Set -> Char-Set)))] + [char-set-unfold! + (All (A) ((A -> Any) (A -> Char) (A -> A) A Char-Set -> Char-Set))] + [char-set-for-each (All (A) ((Char -> A) Char-Set -> (U A Void)))] + [char-set-any (All (A) ((Char -> A) Char-Set -> (U A #f)))] + [char-set-every (All (A) ((Char -> A) Char-Set -> (U A Boolean)))] ) ; end of require/typed ;; Definitions provided here for polymorphism - -(: char-set-fold (All (A) ((Char A -> A) A Char-Set -> A))) +#; (define (char-set-fold comb base cs) (let loop ((c (char-set-cursor cs)) (b base)) (cond [(end-of-char-set? c) b] [else (loop (char-set-cursor-next cs c) (comb (char-set-ref cs c) b))]))) - -(: char-set-unfold - (All (A) - (case-lambda - ((A -> Any) (A -> Char) (A -> A) A -> Char-Set) - ((A -> Any) (A -> Char) (A -> A) A Char-Set -> Char-Set)))) +#; (define char-set-unfold (pcase-lambda: (A) [([p : (A -> Any)] [f : (A -> Char)] [g : (A -> A)] [seed : A]) @@ -115,29 +120,25 @@ [([p : (A -> Any)] [f : (A -> Char)] [g : (A -> A)] [seed : A] [base-cs : Char-Set]) (char-set-unfold! p f g seed (char-set-copy base-cs))])) - -(: char-set-unfold! - (All (A) ((A -> Any) (A -> Char) (A -> A) A Char-Set -> Char-Set))) +#; (define (char-set-unfold! p f g seed base-cs) (let lp ((seed seed) (cs base-cs)) (if (p seed) cs ; P says we are done. (lp (g seed) ; Loop on (G SEED). (char-set-adjoin! cs (f seed)))))) -(: char-set-for-each (All (A) ((Char -> A) Char-Set -> (U A Void)))) +#; (define (char-set-for-each f cs) (char-set-fold (lambda: ([c : Char] [b : (U A Void)]) (f c)) (void) cs)) - -(: char-set-any (All (A) ((Char -> A) Char-Set -> (U A #f)))) +#; (define (char-set-any pred cs) (let loop ((c (char-set-cursor cs))) (and (not (end-of-char-set? c)) (or (pred (char-set-ref cs c)) (loop (char-set-cursor-next cs c)))))) - -(: char-set-every (All (A) ((Char -> A) Char-Set -> (U A Boolean)))) +#; (define (char-set-every pred cs) (let loop ((c (char-set-cursor cs)) (b (ann #t (U #t A)))) (cond [(end-of-char-set? c) b] diff --git a/collects/web-server/http/request.ss b/collects/web-server/http/request.ss index 6a89746f4e..ffe274b741 100644 --- a/collects/web-server/http/request.ss +++ b/collects/web-server/http/request.ss @@ -152,11 +152,14 @@ (define (read-bindings&post-data/raw conn meth uri headers) (cond [(bytes-ci=? #"GET" meth) - (values (map (match-lambda - [(list-rest k v) - (make-binding:form (string->bytes/utf-8 (symbol->string k)) - (string->bytes/utf-8 v))]) - (url-query uri)) + (values (filter (lambda (x) x) + (map (match-lambda + [(list-rest k v) + (if (and (symbol? k) (string? v)) + (make-binding:form (string->bytes/utf-8 (symbol->string k)) + (string->bytes/utf-8 v)) + #f)]) + (url-query uri))) #f)] [(bytes-ci=? #"POST" meth) (local diff --git a/collects/web-server/scribblings/configuration.scrbl b/collects/web-server/scribblings/configuration.scrbl index 43d576d1d3..b51bc9840b 100644 --- a/collects/web-server/scribblings/configuration.scrbl +++ b/collects/web-server/scribblings/configuration.scrbl @@ -234,6 +234,10 @@ turn the paths given in the @scheme[configuration-table] into responders for the Generates a @scheme[response/full] with the given @scheme[http-code] and @scheme[short-version] as the corresponding fields; with the content of the @scheme[text-file] as the body; and, with the @scheme[header]s as, you guessed it, headers. + +This does not cause redirects to a well-known URL, such as @filepath{conf/not-found.html}, but rather use the contents +of @filepath{not-found.html} (for example) as its contents. Therefore, any relative URLs in @scheme[text-file] are relative +to whatever URL @scheme[file-response] is used to respond @emph{to}. Thus, you should probably use absolute URLs in these files. } @defproc[(servlet-loading-responder (url url?) (exn exn?)) diff --git a/collects/xml/private/structures.ss b/collects/xml/private/structures.ss index b211c2b8f4..52d4708124 100644 --- a/collects/xml/private/structures.ss +++ b/collects/xml/private/structures.ss @@ -111,7 +111,7 @@ (struct (attribute source) ([start location/c] [stop location/c] [name symbol?] - [value string?])) + [value (or/c string? permissive/c)])) [permissive? (parameter/c boolean?)] [permissive/c contract?] [content/c contract?] diff --git a/collects/xml/private/xexpr.ss b/collects/xml/private/xexpr.ss index 38fdf7616d..f7d536251f 100644 --- a/collects/xml/private/xexpr.ss +++ b/collects/xml/private/xexpr.ss @@ -129,7 +129,8 @@ ;; True if the list is a list of String,Symbol pairs. (define (attribute-symbol-string? attr true false) (if (symbol? (car attr)) - (if (string? (cadr attr)) + (if (or (string? (cadr attr)) + (permissive?)) (true) (false (make-exn:invalid-xexpr (format "Expected a string, given ~a" (cadr attr)) diff --git a/collects/xml/xml.scrbl b/collects/xml/xml.scrbl index 36d98fae47..7ca86aa9c3 100644 --- a/collects/xml/xml.scrbl +++ b/collects/xml/xml.scrbl @@ -28,6 +28,7 @@ called an @deftech{X-expression}. The @schememodname[xml] library does not provide Document Type Declaration (DTD) processing, including preservation of DTDs in read documents, or validation. It also does not expand user-defined entities or read user-defined entities in attributes. +It does interpret namespaces either. @; ---------------------------------------------------------------------- @@ -96,7 +97,7 @@ Represents a document.} [content (listof content/c)])]{ Represents an element.} -@defstruct[(attribute source) ([name symbol?] [value string?])]{ +@defstruct[(attribute source) ([name symbol?] [value (or/c string? permissive/c)])]{ Represents an attribute within an element.} diff --git a/doc/release-notes/mred/HISTORY.txt b/doc/release-notes/mred/HISTORY.txt index 5776acfd64..1fa020db74 100644 --- a/doc/release-notes/mred/HISTORY.txt +++ b/doc/release-notes/mred/HISTORY.txt @@ -1,4 +1,10 @@ -Version 4.1.4, January 2008 +Version 4.1.5, March 2009 + +Minor bug fixes + +---------------------------------------------------------------------- + +Version 4.1.4, January 2009 Changed image-snip% to implement equal<%> diff --git a/doc/release-notes/mzscheme/HISTORY.txt b/doc/release-notes/mzscheme/HISTORY.txt index f45f79c843..6713c0f407 100644 --- a/doc/release-notes/mzscheme/HISTORY.txt +++ b/doc/release-notes/mzscheme/HISTORY.txt @@ -1,12 +1,24 @@ -Version 4.1.4.3 +Version 4.1.5.3 +Change provide to convert an exported rename transformer to its + free-identifier=? target +Add 'not-free-identifier=? syntax property to disable free-identifier=? + propagation through a rename transformer +Add prop:rename-transformer and prop:set!-transformer +Fix scheme/local so that local syntax bindings are visible to later + local definitions +Changed current-process-milliseconds to accept a thread argument + +Version 4.1.5.2 +Changed expander to detect a reaname transformer and install a + free-identifier=? syntax-object equivalence + +Version 4.1.5, March 2009 Allow infix notation for prefab structure literals Change quasiquote so that unquote works in value positions of #hash Change read-syntax to represent #hash value forms as syntax - -Version 4.1.4.2 Added bitwise-bit-field -Version 4.1.4, January 2008 +Version 4.1.4, January 2009 Changed memory accounting to bias charges to parent instead of children Changed function contracts to preserve tail recursion in many cases Added scheme/package, scheme/splicing, ffi/objc diff --git a/doc/release-notes/stepper/HISTORY.txt b/doc/release-notes/stepper/HISTORY.txt index d7ccd3378f..a97dcc2374 100644 --- a/doc/release-notes/stepper/HISTORY.txt +++ b/doc/release-notes/stepper/HISTORY.txt @@ -1,6 +1,10 @@ Stepper ------- +Changes for v4.1.5: + +Minor bug fixes. + Changes for v4.1.4: None. diff --git a/doc/release-notes/teachpack/HISTORY.txt b/doc/release-notes/teachpack/HISTORY.txt index f27c57b7b6..8c5523402d 100644 --- a/doc/release-notes/teachpack/HISTORY.txt +++ b/doc/release-notes/teachpack/HISTORY.txt @@ -1,5 +1,5 @@ ------------------------------------------------------------------------ -Version 4.1.****** [Sat Feb 14 20:12:23 EST 2009] +Version 4.1.5 [Sat Feb 14 20:12:23 EST 2009] * the universe teachpack exports iworld, not world now diff --git a/src/configure b/src/configure index 5dd4a89108..ae2482e643 100755 --- a/src/configure +++ b/src/configure @@ -6038,6 +6038,67 @@ fi if test "$inline" = "no" ; then MZOPTIONS="$MZOPTIONS -DNO_INLINE_KEYWORD" +fi +{ echo "$as_me:$LINENO: result: $inline" >&5 +echo "${ECHO_T}$inline" >&6; } + + msg="for noinline attribute" +{ echo "$as_me:$LINENO: checking $msg" >&5 +echo $ECHO_N "checking $msg... $ECHO_C" >&6; } +if test "$cross_compiling" = yes; then + noinline=no +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +static int foo() __attribute__ ((noinline)); + static int foo() { return 0; } + int main() { + return foo(); + } +_ACEOF +rm -f conftest$ac_exeext +if { (ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_link") 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { ac_try='./conftest$ac_exeext' + { (case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_try") 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + noinline=yes +else + echo "$as_me: program exited with status $ac_status" >&5 +echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +( exit $ac_status ) +noinline=no +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext +fi + + +if test "$noinline" = "yes" ; then + +cat >>confdefs.h <<\_ACEOF +#define MZ_USE_NOINLINE 1 +_ACEOF + fi { echo "$as_me:$LINENO: result: $inline" >&5 echo "${ECHO_T}$inline" >&6; } @@ -11953,8 +12014,12 @@ if test "${enable_mred}" = "yes" ; then makefiles="$makefiles mred/Makefile mred/wxs/Makefile mred/wxme/Makefile - mred/gc2/Makefile + mred/gc2/Makefile" + + if test "${enable_libpng}" != "yes" ; then + makefiles="$makefiles wxcommon/libpng/Makefile wxcommon/zlib/Makefile" + fi if test "${enable_quartz}" = "yes" ; then makefiles="$makefiles diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index 016404bd68..69b2775995 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -1733,17 +1733,17 @@ static Scheme_Object *foreign_compiler_sizeof(int argc, Scheme_Object *argv[]) if (basetype == 0) basetype = 1; /* int is the default type */ /* don't assume anything, so it can be used to verify compiler assumptions */ /* (only forbid stuff that the compiler doesn't allow) */ -#define RETSIZE(t) res=((stars==0)?sizeof(t):sizeof(t *)) +# define RETSIZE(t) res=((stars==0)?sizeof(t):sizeof(t *)) switch (basetype) { case 1: /* int */ switch (intsize) { case 0: RETSIZE(int); break; case 1: RETSIZE(long int); break; -#ifdef INT64_AS_LONG_LONG +# ifdef INT64_AS_LONG_LONG case 2: RETSIZE(_int64); break; /* MSVC doesn't allow long long */ -#else +# else /* INT64_AS_LONG_LONG undefined */ case 2: RETSIZE(long long int); break; -#endif +# endif /* INT64_AS_LONG_LONG */ case -1: RETSIZE(short int); break; } break; @@ -1768,7 +1768,7 @@ static Scheme_Object *foreign_compiler_sizeof(int argc, Scheme_Object *argv[]) scheme_signal_error(MYNAME": internal error (unexpected type %d)", basetype); } -#undef RETSIZE +# undef RETSIZE return scheme_make_integer(res); } #undef MYNAME @@ -2138,8 +2138,8 @@ static Scheme_Object *abs_sym; /* (ptr-ref cpointer type [['abs] n]) -> the object at the given location */ /* n defaults to 0 which is the only value that should be used with ffi_objs */ -/* if n is given, an 'abs flag can precede it to make n be a byte offset rather - * than some multiple of sizeof(type). */ +/* if n is given, an 'abs flag can precede it to make n be a byte offset */ +/* rather than some multiple of sizeof(type). */ /* WARNING: there are *NO* checks at all, this is raw C level code. */ #define MYNAME "ptr-ref" static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[]) @@ -2191,8 +2191,8 @@ static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[]) /* (ptr-set! cpointer type [['abs] n] value) -> void */ /* n defaults to 0 which is the only value that should be used with ffi_objs */ -/* if n is given, an 'abs flag can precede it to make n be a byte offset rather - * than some multiple of sizeof(type). */ +/* if n is given, an 'abs flag can precede it to make n be a byte offset */ +/* rather than some multiple of sizeof(type). */ /* WARNING: there are *NO* checks at all, this is raw C level code. */ #define MYNAME "ptr-set!" static Scheme_Object *foreign_ptr_set_bang(int argc, Scheme_Object *argv[]) @@ -2253,11 +2253,11 @@ static Scheme_Object *foreign_ptr_equal_p(int argc, Scheme_Object *argv[]) /* (make-sized-byte-string cpointer len) */ #define MYNAME "make-sized-byte-string" static Scheme_Object *foreign_make_sized_byte_string(int argc, Scheme_Object *argv[]) -/* Warning: no copying is done so it is possible to share string contents. */ -/* Warning: if source ptr has a offset, resulting string object uses shifted - * pointer. - * (Should use real byte-strings with new version.) */ { + /* Warning: no copying is done so it is possible to share string contents. */ + /* Warning: if source ptr has a offset, resulting string object uses shifted + * pointer. + * (Should use real byte-strings with new version.) */ long len; if (!SCHEME_FFIANYPTRP(argv[0])) scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv); @@ -2302,31 +2302,29 @@ void do_ptr_finalizer(void *p, void *finalizer) /* unreachable, and it will get a new cpointer object that points to it. */ /* (Only needed in cases where pointer aliases might be created.) */ /* - -(defsymbols pointer) -(cdefine register-finalizer 2 3) -{ - void *ptr, *old = NULL; - int ptrsym = (argc == 3 && argv[2] == pointer_sym); - if (ptrsym) { - if (!SCHEME_FFIANYPTRP(argv[0])) - scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv); - ptr = SCHEME_FFIANYPTR_VAL(argv[0]); - if (ptr == NULL) - scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); - } else { - if (argc == 3) - scheme_wrong_type(MYNAME, "pointer-mode", 2, argc, argv); - ptr = argv[0]; - } - if (!(SCHEME_FALSEP(argv[1]) || SCHEME_PROCP(argv[1]))) - scheme_wrong_type(MYNAME, "procedure-or-false", 1, argc, argv); - scheme_register_finalizer - (ptr, (ptrsym ? do_ptr_finalizer : do_scm_finalizer), - argv[1], NULL, &old); - return (old == NULL) ? scheme_false : (Scheme_Object*)old; -} -*/ + * defsymbols[pointer] + * cdefine[register-finalizer 2 3]{ + * void *ptr, *old = NULL; + * int ptrsym = (argc == 3 && argv[2] == pointer_sym); + * if (ptrsym) { + * if (!SCHEME_FFIANYPTRP(argv[0])) + * scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv); + * ptr = SCHEME_FFIANYPTR_VAL(argv[0]); + * if (ptr == NULL) + * scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); + * } else { + * if (argc == 3) + * scheme_wrong_type(MYNAME, "pointer-mode", 2, argc, argv); + * ptr = argv[0]; + * } + * if (!(SCHEME_FALSEP(argv[1]) || SCHEME_PROCP(argv[1]))) + * scheme_wrong_type(MYNAME, "procedure-or-false", 1, argc, argv); + * scheme_register_finalizer + * (ptr, (ptrsym ? do_ptr_finalizer : do_scm_finalizer), + * argv[1], NULL, &old); + * return (old == NULL) ? scheme_false : (Scheme_Object*)old; + * } + */ /*****************************************************************************/ /* Calling foreign function objects */ @@ -2415,7 +2413,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) /* Otherwise it was a struct pointer, and avalues[i] is already fine. */ /* Add offset, if any: */ if (offsets[i] != 0) { - ivals[i].x_pointer = (char *)ivals[i].x_pointer + offsets[i]; + ivals[i].x_pointer = (char *)ivals[i].x_pointer + offsets[i]; } } /* Finally, call the function */ @@ -2643,16 +2641,16 @@ static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[]) data->itypes = (argv[1]); data->otype = (argv[2]); data->call_in_scheduler = (((argc > 4) && SCHEME_TRUEP(argv[4]))); -#ifdef MZ_PRECISE_GC +# ifdef MZ_PRECISE_GC { /* put data in immobile, weak box */ void **tmp; tmp = GC_malloc_immobile_box(GC_malloc_weak_box(data, NULL, 0)); cl_cif_args->data = (struct immobile_box*)tmp; } -#else +# else /* MZ_PRECISE_GC undefined */ cl_cif_args->data = (void*)data; -#endif +# endif /* MZ_PRECISE_GC */ if (ffi_prep_closure(cl, cif, &ffi_do_callback, (void*)(cl_cif_args->data)) != FFI_OK) scheme_signal_error @@ -2697,12 +2695,12 @@ void scheme_init_foreign(Scheme_Env *env) ffi_obj_tag = scheme_make_type(""); ctype_tag = scheme_make_type(""); ffi_callback_tag = scheme_make_type(""); -#ifdef MZ_PRECISE_GC +# ifdef MZ_PRECISE_GC GC_register_traversers(ffi_lib_tag, ffi_lib_SIZE, ffi_lib_MARK, ffi_lib_FIXUP, 1, 0); GC_register_traversers(ffi_obj_tag, ffi_obj_SIZE, ffi_obj_MARK, ffi_obj_FIXUP, 1, 0); GC_register_traversers(ctype_tag, ctype_SIZE, ctype_MARK, ctype_FIXUP, 1, 0); GC_register_traversers(ffi_callback_tag, ffi_callback_SIZE, ffi_callback_MARK, ffi_callback_FIXUP, 1, 0); -#endif +# endif /* MZ_PRECISE_GC */ scheme_set_type_printer(ctype_tag, ctype_printer); MZ_REGISTER_STATIC(opened_libs); opened_libs = scheme_make_hash_table(SCHEME_hash_string); @@ -2757,7 +2755,7 @@ void scheme_init_foreign(Scheme_Env *env) scheme_add_global("make-ctype", scheme_make_prim_w_arity(foreign_make_ctype, "make-ctype", 3, 3), menv); scheme_add_global("make-cstruct-type", - scheme_make_prim_w_arity(foreign_make_cstruct_type, "make-cstruct-type", 1, 1), menv); + scheme_make_prim_w_arity(foreign_make_cstruct_type, "make-cstruct-type", 1, 2), menv); scheme_add_global("ffi-callback?", scheme_make_prim_w_arity(foreign_ffi_callback_p, "ffi-callback?", 1, 1), menv); scheme_add_global("cpointer?", diff --git a/src/foreign/foreign.ssc b/src/foreign/foreign.ssc index 4a19b20652..20bd47d594 100755 --- a/src/foreign/foreign.ssc +++ b/src/foreign/foreign.ssc @@ -1,24 +1,17 @@ #!/bin/sh -#| -exec mzpp -s "---begin" -o `echo "$0" | sed 's/ssc$/c/'` "$0" +#| -*- C -*- +exec mzscheme "$0" > `echo "$0" | sed 's/ssc$/c/'` "$0" |# ----begin -<<{:<<>>:}>> -/******************************************** - ** Do not edit this file! - ** This file is generated from {:current-file:}, - ** to make changes, edit that file and - ** run it to generate an updated version - ** of this file. - ** NOTE: This is no longer true, foreign.ssc needs to be updated to work with - ** the scribble/text preprocessor instead. - ********************************************/ -{:(load "ssc-utils.ss"):} +#lang scribble/text + +@(require "ssc-utils.ss") + +@header{foreign.ssc} #include "schpriv.h" -#ifndef WINDOWS_DYNAMIC_LOAD +@@@IFNDEF{WINDOWS_DYNAMIC_LOAD}{ # include @@ -59,7 +52,7 @@ exec mzpp -s "---begin" -o `echo "$0" | sed 's/ssc$/c/'` "$0" # error "configuration error, please contact PLT (int64)" # endif -#else +}{ # include # ifndef __CYGWIN32__ @@ -74,7 +67,7 @@ exec mzpp -s "---begin" -o `echo "$0" | sed 's/ssc$/c/'` "$0" typedef unsigned _int64 Tuint64; # endif -#endif +} #include "ffi.h" @@ -95,7 +88,7 @@ exec mzpp -s "---begin" -o `echo "$0" | sed 's/ssc$/c/'` "$0" only available in NT 4.0 and later. The alternative, Module32{First,Next}, is available *except* for NT 4.0! So we try EnumProcessModules first. */ -#ifdef WINDOWS_DYNAMIC_LOAD +@@IFDEF{WINDOWS_DYNAMIC_LOAD}{ #ifdef MZ_PRECISE_GC START_XFORM_SKIP; #endif @@ -153,25 +146,23 @@ BOOL mzEnumProcessModules(HANDLE hProcess, HMODULE* lphModule, } } - #ifdef MZ_PRECISE_GC END_XFORM_SKIP; #endif -#endif +} /*****************************************************************************/ /* Library objects */ -{:(cdefstruct ffi-lib - (handle "void*") - (name "Scheme_Object*") - (objects "Scheme_Hash_Table*")):} +@cdefstruct[ffi-lib + [handle "void*"] + [name "Scheme_Object*"] + [objects "Scheme_Hash_Table*"]] static Scheme_Hash_Table *opened_libs; /* (ffi-lib filename no-error?) -> ffi-lib */ -{:(cdefine ffi-lib 1 2):} -{ +@cdefine[ffi-lib 1 2]{ char *name; Scheme_Object *path, *hashname; void *handle; @@ -187,34 +178,32 @@ static Scheme_Hash_Table *opened_libs; lib = (ffi_lib_struct*)scheme_hash_get(opened_libs, hashname); if (!lib) { Scheme_Hash_Table *ht; -#ifdef WINDOWS_DYNAMIC_LOAD - if (name==NULL) { - /* openning the executable is marked by a NULL handle */ - handle = NULL; - null_ok = 1; - } else - handle = LoadLibrary(name); -#else - handle = dlopen(name, RTLD_NOW | RTLD_GLOBAL); -#endif + @@@IFDEF{WINDOWS_DYNAMIC_LOAD}{ + if (name==NULL) { + /* openning the executable is marked by a NULL handle */ + handle = NULL; + null_ok = 1; + } else + handle = LoadLibrary(name); + }{ + handle = dlopen(name, RTLD_NOW | RTLD_GLOBAL); + } if (handle == NULL && !null_ok) { if (argc > 1 && SCHEME_TRUEP(argv[1])) return scheme_false; else { -#ifdef WINDOWS_DYNAMIC_LOAD - long err; - err = GetLastError(); - scheme_raise_exn(MZEXN_FAIL_FILESYSTEM, - MYNAME": couldn't open %V (%E)", argv[0], err); -#else - scheme_raise_exn(MZEXN_FAIL_FILESYSTEM, - MYNAME": couldn't open %V (%s)", argv[0], dlerror()); -#endif + @@@IFDEF{WINDOWS_DYNAMIC_LOAD}{ + long err; + err = GetLastError(); + scheme_raise_exn(MZEXN_FAIL_FILESYSTEM, + MYNAME": couldn't open %V (%E)", argv[0], err); + }{ + scheme_raise_exn(MZEXN_FAIL_FILESYSTEM, + MYNAME": couldn't open %V (%s)", argv[0], dlerror()); + } } } ht = scheme_make_hash_table(SCHEME_hash_string); - {:(cmake-object "lib" ffi-lib - "handle" "argv[0]" - "ht"):} + @cmake["lib" ffi-lib "handle" "argv[0]" "ht"] scheme_hash_set(opened_libs, hashname, (Scheme_Object*)lib); /* no dlclose finalizer - since the hash table always keeps a reference */ /* maybe add some explicit unload at some point */ @@ -223,8 +212,7 @@ static Scheme_Hash_Table *opened_libs; } /* (ffi-lib-name ffi-lib) -> string */ -{:(cdefine ffi-lib-name 1):} -{ +@cdefine[ffi-lib-name 1]{ if (!SCHEME_FFILIBP(argv[0])) scheme_wrong_type(MYNAME, "ffi-lib", 0, argc, argv); return ((ffi_lib_struct*)argv[0])->name; @@ -233,14 +221,13 @@ static Scheme_Hash_Table *opened_libs; /*****************************************************************************/ /* Pull pointers (mostly functions) out of ffi-lib objects */ -{:(cdefstruct ffi-obj - (obj "void*") - (name "char*") - (lib "ffi_lib_struct*")):} +@cdefstruct[ffi-obj + [obj "void*"] + [name "char*"] + [lib "ffi_lib_struct*"]] /* (ffi-obj objname ffi-lib-or-libname) -> ffi-obj */ -{:(cdefine ffi-obj 2):} -{ +@cdefine[ffi-obj 2]{ ffi_obj_struct *obj; void *dlobj; ffi_lib_struct *lib = NULL; @@ -256,35 +243,35 @@ static Scheme_Hash_Table *opened_libs; dlname = SCHEME_BYTE_STR_VAL(argv[0]); obj = (ffi_obj_struct*)scheme_hash_get(lib->objects, (Scheme_Object*)dlname); if (!obj) { -#ifdef WINDOWS_DYNAMIC_LOAD + @@@IFDEF{WINDOWS_DYNAMIC_LOAD}{ if (lib->handle) { dlobj = GetProcAddress(lib->handle, dlname); } else { /* this is for the executable-open case, which was marked by a NULL * handle, deal with it by searching all current modules */ -# define NUM_QUICK_MODS 16 + @DEFINE{NUM_QUICK_MODS 16} HMODULE *mods, me, quick_mods[NUM_QUICK_MODS]; DWORD cnt = NUM_QUICK_MODS * sizeof(HMODULE), actual_cnt, i; me = GetCurrentProcess(); mods = quick_mods; if (mzEnumProcessModules(me, mods, cnt, &actual_cnt)) { if (actual_cnt > cnt) { - cnt = actual_cnt; - mods = (HMODULE *)scheme_malloc_atomic(cnt); - if (!mzEnumProcessModules(me, mods, cnt, &actual_cnt)) - mods = NULL; - } else - cnt = actual_cnt; + cnt = actual_cnt; + mods = (HMODULE *)scheme_malloc_atomic(cnt); + if (!mzEnumProcessModules(me, mods, cnt, &actual_cnt)) + mods = NULL; + } else + cnt = actual_cnt; } else - mods = NULL; + mods = NULL; if (mods) { - cnt /= sizeof(HMODULE); - for (i = 0; i < cnt; i++) { - dlobj = GetProcAddress(mods[i], dlname); - if (dlobj) break; - } + cnt /= sizeof(HMODULE); + for (i = 0; i < cnt; i++) { + dlobj = GetProcAddress(mods[i], dlname); + if (dlobj) break; + } } else - dlobj = NULL; + dlobj = NULL; } if (!dlobj) { long err; @@ -293,7 +280,7 @@ static Scheme_Hash_Table *opened_libs; MYNAME": couldn't get \"%s\" from %V (%E)", dlname, lib->name, err); } -#else + }{ dlobj = dlsym(lib->handle, dlname); if (!dlobj) { const char *err; @@ -303,24 +290,22 @@ static Scheme_Hash_Table *opened_libs; MYNAME": couldn't get \"%s\" from %V (%s)", dlname, lib->name, err); } -#endif - {:(cmake-object "obj" ffi-obj "dlobj" "dlname" "lib"):} + } + @cmake["obj" ffi-obj "dlobj" "dlname" "lib"] scheme_hash_set(lib->objects, (Scheme_Object*)dlname, (Scheme_Object*)obj); } return (obj == NULL) ? scheme_false : (Scheme_Object*)obj; } /* (ffi-obj-lib ffi-obj) -> ffi-lib */ -{:(cdefine ffi-obj-lib 1):} -{ +@cdefine[ffi-obj-lib 1]{ if (!SCHEME_FFIOBJP(argv[0])) scheme_wrong_type(MYNAME, "ffi-obj", 0, argc, argv); return (Scheme_Object*)(((ffi_obj_struct*)argv[0])->lib); } /* (ffi-obj-name ffi-obj) -> string */ -{:(cdefine ffi-obj-name 1):} -{ +@cdefine[ffi-obj-name 1]{ if (!SCHEME_FFIOBJP(argv[0])) scheme_wrong_type(MYNAME, "ffi-obj", 0, argc, argv); return scheme_make_byte_string(((ffi_obj_struct*)argv[0])->name); @@ -337,7 +322,7 @@ static Scheme_Hash_Table *opened_libs; #define scheme_make_integer_from_unsigned(i) \ ((Scheme_Object *)((((unsigned long)i) << 1) | 0x1)) -#ifndef SIXTY_FOUR_BIT_INTEGERS +@@@IFNDEF{SIXTY_FOUR_BIT_INTEGERS}{ /* longs and ints are really the same */ #define scheme_get_realint_val(x,y) \ @@ -349,7 +334,7 @@ static Scheme_Hash_Table *opened_libs; #define scheme_make_realinteger_value_from_unsigned \ scheme_make_integer_value_from_unsigned -#else /* SIXTY_FOUR_BIT_INTEGERS defined */ +}{ /* These will make sense in MzScheme when longs are longer than ints (needed * for libffi's int32 types). There is no need to deal with bignums because @@ -381,7 +366,7 @@ inline int scheme_get_unsigned_realint_val(Scheme_Object *o, unsigned int *v) #define scheme_make_realinteger_value_from_unsigned(ri) \ scheme_make_integer((unsigned long)(ri)) -#endif /* SIXTY_FOUR_BIT_INTEGERS */ +} /* This is related to the section of scheme.h that defines mzlonglong. */ #ifndef INT64_AS_LONG_LONG @@ -430,7 +415,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) /*****************************************************************************/ /* Types */ -{: +@(begin ;; Types are defined with the `defctype' function. This looks like: ;; (defctype 'type-name ;; 'prop1 val1 @@ -455,38 +440,39 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) ;; offset: if specified as "X", use "SCHEME_X_OFFSET" to extract an offset ;; value for s->c, otherwise leave 0 as the offset -(define types '()) +(define types null) + +(require (for-syntax scheme/base)) (define (get-prop type prop) (cadr (assq prop (cdr (assq type types))))) -(define *type-counter* 0) +(define type-counter + (let ([c 0]) + (lambda ([flag #f]) + (case flag + [(#f) (set! c (add1 c)) c] + [(last) (begin0 (add1 c) (set! c #f))] + [else (error "internal error")])))) -(define (describe-type type stype cname ftype ctype pred s->c c->s offset) - (set! *type-counter* (add1 *type-counter*)) - (~ "#define FOREIGN_"cname" ("*type-counter*")" \\ - "/* Type Name: "stype (and (not (equal? cname stype)) - (list " ("cname")")) \\ - " * LibFfi type: ffi_type_"ftype \\ - " * C type: "(or ctype "-none-") \\ - " * Predicate: "(cond [(not pred) "-none-"] - [(procedure? pred) (pred "" "aux")] - [else (list pred"()")]) \\ - " * Scheme->C: "(cond - [(not s->c) - (if pred "-none- (set by the predicate)" "-none-")] - [(procedure? s->c) (s->c "" "aux")] - [else (list s->c"()")]) \\ - " * S->C offset: "(cond - [(not offset) "0"] - [else offset]) \\ - " * C->Scheme: "(cond [(not c->s) "-none-"] - [(procedure? c->s) (c->s "")] - [else (list c->s"()")]) \\ - " */" \\ - ;; no need for these, at least for now: - ;; "static Scheme_Object *"cname"_sym;"\\ - )) +(define (describe-type stype cname ftype ctype pred s->c c->s offset) + @list{ + #define FOREIGN_@cname (@(type-counter)) + /* Type Name: @stype@(and (not (equal? cname stype)) @list{ (@cname)}) + * LibFfi type: ffi_type_@ftype + * C type: @(or ctype "-none-") + * Predicate: @(cond [(not pred) "-none-"] + [(procedure? pred) (pred "" "aux")] + [else @list{@|pred|()}]) + * Scheme->C: @(cond [(not s->c) + (if pred "-none- (set by the predicate)" "-none-")] + [(procedure? s->c) (s->c "" "aux")] + [else @list{@|s->c|()}]) + * S->C offset: @(or offset 0) + * C->Scheme: @(cond [(not c->s) "-none-"] + [(procedure? c->s) (c->s "")] + [else @list{@|c->s|()}]) + */}) (define (make-ctype type args) (define (prop p . default) @@ -507,22 +493,29 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) "int"))] [ftype (regexp-replace #rx"^(int|char|long)" ftype "s\\1")] [macro (prop 'macro)] - [pred (prop 'pred (and macro (list "SCHEME_"macro"P")))] - [s->c (prop 's->c (and macro (list "SCHEME_"macro"_VAL")))] + [pred (prop 'pred (and macro @list{SCHEME_@|macro|P}))] + [s->c (prop 's->c (and macro @list{SCHEME_@|macro|_VAL}))] [c->s (prop 'c->s)] [offset (prop 'offset #f)]) - (describe-type type stype cname ftype ctype pred s->c c->s offset) + (output (describe-type stype cname ftype ctype pred s->c c->s offset)) `(,type (stype ,stype) (cname ,cname) (ftype ,ftype) (ctype ,ctype) (macro ,macro) (pred ,pred) (s->c ,s->c) (c->s ,c->s) (offset ,offset)))) (define (defctype name . args) - (set! types (append! types (list (make-ctype name args))))) + (set! types (append types (list (make-ctype name args))))) -(define-syntax (for-each-type stx) +(define-syntax (map-types stx) (syntax-case stx () [(_ body ...) - (let ([id (lambda (sym) (datum->syntax-object (syntax _) sym))]) - (with-syntax ([stype (id 'stype)] + (let () + (define (id sym) (datum->syntax stx sym stx)) + (define-values (exprs semi?) + (syntax-case stx () + [(_ #:semicolons? s? body ...) (values #'(body ...) #'s?)] + [(_ body ...) (values #'(body ...) #'#t)])) + (with-syntax ([(body ...) exprs] + [semi? semi?] + [stype (id 'stype)] [cname (id 'cname)] [ctype (id 'ctype)] [ftype (id 'ftype)] @@ -532,22 +525,22 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) [c->s (id 'c->s)] [offset (id 'offset)] [ptr? (id 'ptr?)]) - #'(for-each - (lambda (t) - (define data (cdr t)) - (define (get sym) (cadr (assq sym data))) - (let* ([stype (get 'stype)] - [cname (get 'cname)] - [ftype (get 'ftype)] - [ctype (get 'ctype)] - [macro (get 'macro)] - [pred (get 'pred)] - [s->c (get 's->c)] - [c->s (get 'c->s)] - [offset (get 'offset)] - [ptr? (equal? "pointer" ftype)]) - body ...)) - types)))])) + #'(maplines #:semicolons? 'semi? + (lambda (t) + (define data (cdr t)) + (define (get sym) (cadr (assq sym data))) + (let* ([stype (get 'stype)] + [cname (get 'cname)] + [ftype (get 'ftype)] + [ctype (get 'ctype)] + [macro (get 'macro)] + [pred (get 'pred)] + [s->c (get 's->c)] + [c->s (get 'c->s)] + [offset (get 'offset)] + [ptr? (equal? "pointer" ftype)]) + body ...)) + types)))])) (define (defctype* name/+ftype ctype pred s->c c->s) (let ([name (if (pair? name/+ftype) (car name/+ftype) name/+ftype)] @@ -555,192 +548,197 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) (apply defctype name `(ctype ,ctype ,@(if ftype `(ftype ,ftype) `()) - pred ,(if (string? pred) (list "SCHEME_"pred"P") pred) - s->c ,(if (string? s->c) (list "SCHEME_"s->c"_VAL") s->c) - c->s ,(if (string? c->s) (list "scheme_make_"c->s) c->s))))) + pred ,(if (string? pred) @list{SCHEME_@|pred|P} pred) + s->c ,(if (string? s->c) @list{SCHEME_@|s->c|_VAL} s->c) + c->s ,(if (string? c->s) @list{scheme_make_@|c->s|} c->s))))) -(~ "/***********************************************************************"\\ - " * The following are the only primitive types." \\ - " * The tricky part is figuring out what width-ed types correspond to"\\ - " * what internal types. Matthew says:" \\ - " * MzScheme expects to be compiled such that sizeof(int) == 4," \\ - " * sizeof(long) == sizeof(void*), sizeof(short) >= 2," \\ - " * sizeof(char) == 1, sizeof(float) == 4, and sizeof(double) == 8." \\ - " * So, on a 64-bit OS, MzScheme expects only `long' to change." \\ - " **********************************************************************/"\\ - ) +) -(~ "/* returns # when used as output type, not for input types. */") -(defctype 'void - 'ctype #f 'pred #f 's->c #f 'c->s (lambda (x) "scheme_void")) +/*********************************************************************** + * The following are the only primitive types. + * The tricky part is figuring out what width-ed types correspond to + * what internal types. Matthew says: + * MzScheme expects to be compiled such that sizeof(int) == 4, + * sizeof(long) == sizeof(void*), sizeof(short) >= 2, + * sizeof(char) == 1, sizeof(float) == 4, and sizeof(double) == 8. + * So, on a 64-bit OS, MzScheme expects only `long' to change. + **********************************************************************/ -;; libffi primitive types -;; scheme-name c-type SCHEME_?P SCHEME_?_VAL scheme_make_ -(defctype* 'int8 "Tsint8" "INT" "INT" "integer") -(defctype* 'uint8 "Tuint8" "INT" "UINT" "integer_from_unsigned") -(defctype* 'int16 "Tsint16" "INT" "INT" "integer") -(defctype* 'uint16 "Tuint16" "INT" "UINT" "integer_from_unsigned") +/* returns # when used as output type, not for input types. */ +@(defctype 'void + 'ctype #f 'pred #f 's->c #f 'c->s (lambda (x) "scheme_void")) -(~ "/* Treats integers properly: */") -(defctype* 'int32 "Tsint32" - (lambda (x aux) (list "scheme_get_realint_val("x",&"aux")")) #f +@; libffi primitive types +@; scheme-name c-type SCHEME_?P SCHEME_?_VAL scheme_make_ +@(defctype* 'int8 "Tsint8" "INT" "INT" "integer") + +@(defctype* 'uint8 "Tuint8" "INT" "UINT" "integer_from_unsigned") + +@(defctype* 'int16 "Tsint16" "INT" "INT" "integer") + +@(defctype* 'uint16 "Tuint16" "INT" "UINT" "integer_from_unsigned") + +/* Treats integers properly: */ +@(defctype* 'int32 "Tsint32" + (lambda (x aux) @list{scheme_get_realint_val(@x,&@aux)}) #f "realinteger_value") -(~ "/* Treats integers properly: */") -(defctype* 'uint32 "Tuint32" - (lambda (x aux) (list "scheme_get_unsigned_realint_val("x",&"aux")")) #f - "realinteger_value_from_unsigned") -;; mzlonglong is always assumed to be 64 bits, or the above will throw an error -(defctype* 'int64 "Tsint64" - (lambda (x aux) (list "scheme_get_long_long_val("x",&"aux")")) #f - "integer_value_from_long_long") -(defctype* 'uint64 "Tuint64" - (lambda (x aux) (list "scheme_get_unsigned_long_long_val("x",&"aux")")) #f - "integer_value_from_unsigned_long_long") +/* Treats integers properly: */ +@(defctype* 'uint32 "Tuint32" + (lambda (x aux) @list{scheme_get_unsigned_realint_val(@x,&@aux)}) #f + "realinteger_value_from_unsigned") -(~ "/* This is like int32, but always assumes fixnum: */") -(defctype* '(fixint "int32") "Tsint32" "INT" "INT" "integer") -(~ "/* This is like uint32, but always assumes fixnum: */") -(defctype* '(ufixint "uint32") "Tuint32" "INT" "UINT" "integer_from_unsigned") +@; mzlonglong is always assumed to be 64 bits, or the above will throw an error +@(defctype* 'int64 "Tsint64" + (lambda (x aux) @list{scheme_get_long_long_val(@x,&@aux)}) #f + "integer_value_from_long_long") -(~ "/* This is what mzscheme defines as long: */" \\ - "#ifndef SIXTY_FOUR_BIT_INTEGERS" \\ - "#define ffi_type_smzlong ffi_type_sint32" \\ - "#define ffi_type_umzlong ffi_type_uint32" \\ - "#else" \\ - "#define ffi_type_smzlong ffi_type_sint64" \\ - "#define ffi_type_umzlong ffi_type_uint64" \\ - "#endif" \\) +@(defctype* 'uint64 "Tuint64" + (lambda (x aux) @list{scheme_get_unsigned_long_long_val(@x,&@aux)}) #f + "integer_value_from_unsigned_long_long") -#| implemented in Scheme -(~ "/* This is what mzscheme defines as long: */") +/* This is like int32, but always assumes fixnum: */ +@(defctype* '(fixint "int32") "Tsint32" "INT" "INT" "integer") + +/* This is like uint32, but always assumes fixnum: */ +@(defctype* '(ufixint "uint32") "Tuint32" "INT" "UINT" "integer_from_unsigned") + +/* This is what mzscheme defines as long: */ +@@@IFNDEF{SIXTY_FOUR_BIT_INTEGERS}{ +#define ffi_type_smzlong ffi_type_sint32 +#define ffi_type_umzlong ffi_type_uint32 +}{ +#define ffi_type_smzlong ffi_type_sint64 +#define ffi_type_umzlong ffi_type_uint64 +} + +@;{ implemented in Scheme +/* This is what mzscheme defines as long: */ (defctype* '(long "smzlong") "long" - (lambda (x aux) (list "scheme_get_int_val("x",&"aux")")) #f + (lambda (x aux) list{scheme_get_int_val(@x,&@aux)}) #f "integer_value") -(~ "/* This is what mzscheme defines as ulong: */") +@line{/* This is what mzscheme defines as ulong: */} (defctype* '(ulong "umzlong") "unsigned long" - (lambda (x aux) (list "scheme_get_unsigned_int_val("x",&"aux")")) #f + (lambda (x aux) @list{scheme_get_unsigned_int_val(@x,&@aux)}) #f "integer_value_from_unsigned") -|# +;}@; +@; +/* This is what mzscheme defines as long, assuming fixnums: */ +@(defctype* '(fixnum "smzlong") + "long" "INT" "INT" "integer") -(~ "/* This is what mzscheme defines as long, assuming fixnums: */") -(defctype* '(fixnum "smzlong") - "long" "INT" "INT" "integer") -(~ "/* This is what mzscheme defines as ulong, assuming fixnums: */") -(defctype* '(ufixnum "umzlong") - "unsigned long" "INT" "UINT" "integer_from_unsigned") +/* This is what mzscheme defines as ulong, assuming fixnums: */ +@(defctype* '(ufixnum "umzlong") + "unsigned long" "INT" "UINT" "integer_from_unsigned") -(defctype* 'float "float" "FLT" "FLT" "float") -(defctype* 'double "double" "DBL" "DBL" "double") -;; Not useful? not implemented in any case. -;; (defctype* 'longdouble "long double" ...???...) +@(defctype* 'float "float" "FLT" "FLT" "float") -(~ "/* A double that will coerce numbers to doubles: */") -(defctype* '(double* "double") "double" - ;; use a list to avoid automatic "SCHEME_..._VAL" wrapping - "REAL" '("scheme_real_to_double") "double") +@(defctype* 'double "double" "DBL" "DBL" "double") +@; +@; Not useful? not implemented in any case. +@; (defctype* 'longdouble "long double" ...???...) -(~ "/* Booleans -- implemented as an int which is 1 or 0: */") -(defctype 'bool - 'ftype "int" - 'pred (lambda (x aux) "1") - 's->c "SCHEME_TRUEP" - 'c->s (lambda (x) (list "("x"?scheme_true:scheme_false)"))) +/* A double that will coerce numbers to doubles: */ +@(defctype* '(double* "double") "double" + ;; use a list to avoid automatic "SCHEME_..._VAL" wrapping + "REAL" '("scheme_real_to_double") "double") -(~ "/* Strings -- no copying is done (when possible)." \\ - " * #f is not NULL only for byte-strings, for other strings it is" \\ - " * meaningless to use NULL. */" \\ - ) +/* Booleans -- implemented as an int which is 1 or 0: */ +@(defctype 'bool + 'ftype "int" + 'pred (lambda (x aux) "1") + 's->c "SCHEME_TRUEP" + 'c->s (lambda (x) @list{(@|x|?scheme_true:scheme_false)})) -(defctype 'string/ucs-4 - 'ftype "pointer" - 'ctype "mzchar*" - 'pred "SCHEME_FALSEP_OR_CHAR_STRINGP" - 's->c "ucs4_string_or_null_to_ucs4_pointer" - 'c->s "scheme_make_char_string_without_copying") +/* Strings -- no copying is done (when possible). + * #f is not NULL only for byte-strings, for other strings it is + * meaningless to use NULL. */ -(defctype 'string/utf-16 - 'ftype "pointer" - 'ctype "unsigned short*" - 'pred "SCHEME_FALSEP_OR_CHAR_STRINGP" - 's->c "ucs4_string_or_null_to_utf16_pointer" - 'c->s "utf16_pointer_to_ucs4_string") +@(defctype 'string/ucs-4 + 'ftype "pointer" + 'ctype "mzchar*" + 'pred "SCHEME_FALSEP_OR_CHAR_STRINGP" + 's->c "ucs4_string_or_null_to_ucs4_pointer" + 'c->s "scheme_make_char_string_without_copying") -(~ "/* Byte strings -- not copying C strings, #f is NULL." \\ - " * (note: these are not like char* which is just a pointer) */" \\ - ) +@(defctype 'string/utf-16 + 'ftype "pointer" + 'ctype "unsigned short*" + 'pred "SCHEME_FALSEP_OR_CHAR_STRINGP" + 's->c "ucs4_string_or_null_to_utf16_pointer" + 'c->s "utf16_pointer_to_ucs4_string") -(defctype 'bytes - 'ftype "pointer" - 'ctype "char*" - 'pred (lambda (x aux) - (list "SCHEME_FALSEP("x")||SCHEME_BYTE_STRINGP("x")")) - 's->c (lambda (x aux) - (list "SCHEME_FALSEP("x")?NULL:SCHEME_BYTE_STR_VAL("x")")) - 'c->s (lambda (x) - (list "("x"==NULL)?scheme_false:" - "scheme_make_byte_string_without_copying("x")"))) +/* Byte strings -- not copying C strings, #f is NULL. + * (note: these are not like char* which is just a pointer) */ -(defctype 'path - 'ftype "pointer" - 'ctype "char*" - 'pred (lambda (x aux) - (list "SCHEME_FALSEP("x")||SCHEME_PATH_STRINGP("x")")) - 's->c (lambda (x aux) - (list "SCHEME_FALSEP("x")?NULL:SCHEME_PATH_VAL(TO_PATH("x"))")) - 'c->s (lambda (x) - (list "("x"==NULL)?scheme_false:" - "scheme_make_path_without_copying("x")"))) +@(defctype 'bytes + 'ftype "pointer" + 'ctype "char*" + 'pred (lambda (x aux) + @list{SCHEME_FALSEP(@x)||SCHEME_BYTE_STRINGP(@x)}) + 's->c (lambda (x aux) + @list{SCHEME_FALSEP(@x)?NULL:SCHEME_BYTE_STR_VAL(@x)}) + 'c->s (lambda (x) + @list{(@|x|==NULL)?scheme_false:@; + scheme_make_byte_string_without_copying(@x)})) -(defctype 'symbol - 'ftype "pointer" - 'ctype "char*" - 'pred "SCHEME_SYMBOLP" - 's->c "SCHEME_SYM_VAL" - 'c->s "scheme_intern_symbol") +@(defctype 'path + 'ftype "pointer" + 'ctype "char*" + 'pred (lambda (x aux) + @list{SCHEME_FALSEP(@x)||SCHEME_PATH_STRINGP(@x)}) + 's->c (lambda (x aux) + @list{SCHEME_FALSEP(@x)?NULL:SCHEME_PATH_VAL(TO_PATH(@x))}) + 'c->s (lambda (x) + @list{(@|x|==NULL)?scheme_false:@; + scheme_make_path_without_copying(@x)})) -(~ "/* This is for any C pointer: #f is NULL, cpointer values as well as" \\ - " * ffi-obj and string values pass their pointer. When used as a return" \\ - " * value, either a cpointer object or #f is returned. */") -(defctype 'pointer - 'ctype "void*" - 'macro "FFIANYPTR" - 'offset "FFIANYPTR" - 'c->s "scheme_make_foreign_cpointer") +@(defctype 'symbol + 'ftype "pointer" + 'ctype "char*" + 'pred "SCHEME_SYMBOLP" + 's->c "SCHEME_SYM_VAL" + 'c->s "scheme_intern_symbol") -;; This is probably not needed -;; (~ "/* Used for ffi-callback objects: */") -;; (defctype 'callback -;; 'ftype "pointer" -;; 'ctype "void*" -;; 'macro "FFICALLBACK" -;; 's->c (lambda (x aux) (list "((ffi_callback_struct*)("x"))->callback")) -;; 'c->s (lambda (x) x)) +/* This is for any C pointer: #f is NULL, cpointer values as well as + * ffi-obj and string values pass their pointer. When used as a return + * value, either a cpointer object or #f is returned. */ +@(defctype 'pointer + 'ctype "void*" + 'macro "FFIANYPTR" + 'offset "FFIANYPTR" + 'c->s "scheme_make_foreign_cpointer") -(~ "/* This is used for passing and Scheme_Object* value as is. Useful for" \\ - " * functions that know about Scheme_Object*s, like MzScheme's. */") -(defctype 'scheme - 'ftype "pointer" - 'ctype "Scheme_Object*" - 'pred (lambda (x aux) "1") - 's->c (lambda (x aux) x) - 'c->s (lambda (x) x)) +@; This is probably not needed +@; /* Used for ffi-callback objects: */ +@; @(defctype 'callback +@; 'ftype "pointer" +@; 'ctype "void*" +@; 'macro "FFICALLBACK" +@; 's->c (lambda (x aux) @list{((ffi_callback_struct*)(@x))->callback}) +@; 'c->s (lambda (x) x)) +@; +/* This is used for passing and Scheme_Object* value as is. Useful for + * functions that know about Scheme_Object*s, like MzScheme's. */ +@(defctype 'scheme + 'ftype "pointer" + 'ctype "Scheme_Object*" + 'pred (lambda (x aux) "1") + 's->c (lambda (x aux) x) + 'c->s (lambda (x) x)) -(~ "/* Special type, not actually used for anything except to mark values" \\ - " * that are treated like pointers but not referenced. Used for" \\ - " * creating function types. */") -(defctype 'fpointer 'ftype "pointer" 'ctype "void*") +/* Special type, not actually used for anything except to mark values + * that are treated like pointers but not referenced. Used for + * creating function types. */ +@(defctype 'fpointer 'ftype "pointer" 'ctype "void*") -:} typedef union _ForeignAny { - {:(for-each-type (when ctype (~ ctype" x_"cname";"))):} + @(map-types (when ctype @list{@ctype x_@cname})) } ForeignAny; -{: (set! *type-counter* (add1 *type-counter*)) - (~ "/* This is a tag that is used to identify user-made struct types. */" \\ - "#define FOREIGN_struct ("*type-counter*")") - (set! *type-counter* #f) ; make sure this is the last one defined -:} +/* This is a tag that is used to identify user-made struct types. */ +@; last makes sure this is the last one value that gets used +#define FOREIGN_struct (@(type-counter 'last)) /*****************************************************************************/ /* Type objects */ @@ -756,10 +754,10 @@ typedef union _ForeignAny { * integer is not really needed, since it is possible to identify the * type by the basetype field.) */ -{:(cdefstruct ctype - (basetype "Scheme_Object*") - (scheme_to_c "Scheme_Object*") - (c_to_scheme "Scheme_Object*")):} +@cdefstruct[ctype + [basetype "Scheme_Object*"] + [scheme_to_c "Scheme_Object*"] + [c_to_scheme "Scheme_Object*"]] #define CTYPE_BASETYPE(x) (((ctype_struct*)(x))->basetype) #define CTYPE_USERP(x) (CTYPE_BASETYPE(x) != NULL && SCHEME_CTYPEP(CTYPE_BASETYPE(x))) @@ -770,23 +768,20 @@ typedef union _ForeignAny { #define CTYPE_USER_C2S(x) (((ctype_struct*)(x))->c_to_scheme) /* Returns #f for primitive types. */ -{:(cdefine ctype-basetype 1):} -{ +@cdefine[ctype-basetype 1]{ if (!SCHEME_CTYPEP(argv[0])) scheme_wrong_type(MYNAME, "ctype", 0, argc, argv); return CTYPE_BASETYPE(argv[0]); } -{:(cdefine ctype-scheme->c 1):} -{ +@cdefine[ctype-scheme->c 1]{ if (!SCHEME_CTYPEP(argv[0])) scheme_wrong_type(MYNAME, "ctype", 0, argc, argv); return (CTYPE_PRIMP(argv[0])) ? scheme_false : ((ctype_struct*)(argv[0]))->scheme_to_c; } -{:(cdefine ctype-c->scheme 1):} -{ +@cdefine[ctype-c->scheme 1]{ if (!SCHEME_CTYPEP(argv[0])) scheme_wrong_type(MYNAME, "ctype", 0, argc, argv); return (CTYPE_PRIMP(argv[0])) ? scheme_false : @@ -807,9 +802,8 @@ static int ctype_sizeof(Scheme_Object *type) type = get_ctype_base(type); if (type == NULL) return -1; switch (CTYPE_PRIMLABEL(type)) { - {:(for-each-type - (~ "case FOREIGN_"cname": return " - (if ctype (list "sizeof("ctype");") "0;"))):} + @(map-types @list{case FOREIGN_@|cname|: @; + return @(if ctype @list{sizeof(@ctype)} "0")}) /* for structs */ default: return CTYPE_PRIMTYPE(type)->size; } @@ -819,8 +813,7 @@ static int ctype_sizeof(Scheme_Object *type) /* The scheme->c can throw type errors to check for valid arguments */ /* a #f means no conversion function, if both are #f -- then just return the */ /* basetype. */ -{:(cdefine make-ctype 3):} -{ +@cdefine[make-ctype 3]{ ctype_struct *type; if (!SCHEME_CTYPEP(argv[0])) scheme_wrong_type(MYNAME, "C-type", 0, argc, argv); @@ -831,10 +824,10 @@ static int ctype_sizeof(Scheme_Object *type) else if (SCHEME_FALSEP(argv[1]) && SCHEME_FALSEP(argv[2])) return argv[0]; else { - {:(cmake-object "type" ctype "argv[0]" "argv[1]" "argv[2]"):} + @cmake["type" ctype "argv[0]" "argv[1]" "argv[2]"] return (Scheme_Object*)type; } - return NULL; /* hush the compiler */ + @hush } /* see below */ @@ -847,7 +840,7 @@ void free_libffi_type(void *ignored, void *p) /*****************************************************************************/ /* ABI spec */ -{:(defsymbols default stdcall sysv):} +@defsymbols[default stdcall sysv] ffi_abi sym_to_abi(char *who, Scheme_Object *sym) { @@ -882,8 +875,7 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym) /* This creates a new primitive type that is a struct. This type can be used * with cpointer objects, except that the contents is used rather than the * pointer value. Marshaling to lists or whatever should be done in Scheme. */ -{:(cdefine make-cstruct-type 1):} -{ +@cdefine[make-cstruct-type 1 2]{ Scheme_Object *p, *base; /* since ffi_type objects can be used in callbacks, they are allocated using * malloc so they don't move, and they are freed when the Scheme object is @@ -916,9 +908,9 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym) dummy = &libffi_type; if (ffi_prep_cif(&cif, abi, 1, &ffi_type_void, dummy) != FFI_OK) scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK"); - {:(cmake-object "type" ctype "argv[0]" - "(Scheme_Object*)libffi_type" - "(Scheme_Object*)FOREIGN_struct"):} + @cmake["type" ctype "argv[0]" + "(Scheme_Object*)libffi_type" + "(Scheme_Object*)FOREIGN_struct"] scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL); return (Scheme_Object*)type; } @@ -926,12 +918,12 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym) /*****************************************************************************/ /* Callback type */ -{:(cdefstruct ffi-callback - (callback "void*") - (proc "Scheme_Object*") - (itypes "Scheme_Object*") - (otype "Scheme_Object*") - (call_in_scheduler "int")):} +@cdefstruct[ffi-callback + [callback "void*"] + [proc "Scheme_Object*"] + [itypes "Scheme_Object*"] + [otype "Scheme_Object*"] + [call_in_scheduler "int"]] /*****************************************************************************/ /* Pointer objects */ @@ -958,13 +950,11 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym) #define scheme_make_foreign_cpointer(x) \ ((x==NULL)?scheme_false:scheme_make_cptr(x,NULL)) -{:(cdefine cpointer? 1):} -{ +@cdefine[cpointer? 1]{ return SCHEME_FFIANYPTRP(argv[0]) ? scheme_true : scheme_false; } -{:(cdefine cpointer-tag 1):} -{ +@cdefine[cpointer-tag 1]{ Scheme_Object *tag = NULL; if (!SCHEME_FFIANYPTRP(argv[0])) scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv); @@ -972,8 +962,7 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym) return (tag == NULL) ? scheme_false : tag; } -{:(cdefine set-cpointer-tag! 2):} -{ +@cdefine[set-cpointer-tag! 2]{ if (!SCHEME_CPTRP(argv[0])) scheme_wrong_type(MYNAME, "proper-cpointer", 0, argc, argv); SCHEME_CPTR_TYPE(argv[0]) = argv[1]; @@ -1012,17 +1001,17 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, } else if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) { return scheme_make_foreign_cpointer(*(void **)W_OFFSET(src, delta)); } else switch (CTYPE_PRIMLABEL(type)) { - {:(for-each-type - (~ "case FOREIGN_"cname": return " - (if ctype - (let ([x (list "REF_CTYPE("ctype")")]) - (if (procedure? c->s) (c->s x) (list c->s"("x")"))) - "scheme_void")";")):} + @(map-types + @list{case FOREIGN_@|cname|: return @; + @(if ctype + (let ([x (list "REF_CTYPE("ctype")")]) + (if (procedure? c->s) (c->s x) (list c->s"("x")"))) + "scheme_void")}) case FOREIGN_struct: return scheme_make_foreign_cpointer(W_OFFSET(src, delta)); default: scheme_signal_error("corrupt foreign type: %V", type); } - return NULL; /* hush the compiler */ + @hush } #undef REF_CTYPE @@ -1061,57 +1050,59 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, else /* ((void**)W_OFFSET(dst,delta))[0] = val; */ scheme_wrong_type("Scheme->C", "cpointer", 0, 1, &val); } else switch (CTYPE_PRIMLABEL(type)) { - {:(for-each-type - (define (wrong-type obj type) - (list "scheme_wrong_type(\"Scheme->C\",\""type"\",0,1,&("obj"));")) - (~ "case FOREIGN_"cname":") - (if (and ctype (not (equal? stype "fpointer"))) - (let* ([x (list "((("ctype"*)W_OFFSET(dst,delta))[0])")] - [f (lambda (p) - (if (procedure? p) (p "val" x) (list p"(val)")))]) - (if s->c - (begin - (display "#ifdef SCHEME_BIG_ENDIAN\n") - (~ " if (sizeof("ctype")c)");") - (when offset - (~ " toff = SCHEME_"offset"_OFFSET(val);") - (~ " if (_offset) *_offset = toff;")) - (when ptr? - (~ " if (basetype_p == NULL ||" - (if offset - "(tmp == NULL && toff == 0)" - "tmp == NULL") - ") {") - (if offset - (~ " "x" = (_offset ? tmp : ("ctype")W_OFFSET(tmp, toff));") - (~ " "x" = tmp;")) - (~ " return NULL;" \\ - " } else {" \\ - " *basetype_p = FOREIGN_"cname";") - (if offset - (~ " return _offset ? tmp : ("ctype")W_OFFSET(tmp, toff);") - (~ " return tmp;")) - (~ " }")) - (when (not ptr?) - (~ " "x" = tmp; return NULL;")) - (~ " } else {" \\ - " "(wrong-type "val" stype) \\ - " return NULL; /* hush the compiler */" \\ - " }")) - (if ptr? - (error 'scheme->c "unhandled pointer type: ~s" ctype) - (~ " if (!("(pred "val" x)")) "(wrong-type "val" stype) \\ - " return NULL;")))) - (~ " if (!ret_loc) "(wrong-type "type" "non-void-C-type") - ~ " break;"))):} + @(map-types #:semicolons? #f + (define (wrong-type obj type) + @list{scheme_wrong_type("Scheme->C","@type",0,1,&(@obj))}) + @list{ + case FOREIGN_@|cname|: + @(let* ([x (and ctype @list{(((@|ctype|*)W_OFFSET(dst,delta))[0])})] + [f (lambda (p) + (if (procedure? p) @p["val" x] @list{@|p|(val)}))]) + (cond + [(not x) + @list{if (!ret_loc) @wrong-type["type" "non-void-C-type"]; + break; + }] + [(not s->c) + @list{if (!(@(if ptr? "ret_loc" (pred "val" x)))) @; + @wrong-type["val" stype]; + @(if ptr? "break" "return NULL");}] + [else + @list{ + @@IFDEF{SCHEME_BIG_ENDIAN}{ + if (sizeof(@ctype)c]); + @and[offset @list{ + toff = SCHEME_@|offset|_OFFSET(val); + if (_offset) *_offset = toff;@; + @"\n" }]@; + @(if ptr? + @list{if (basetype_p == NULL || @; + @(if offset + @list{(tmp == NULL && toff == 0)} + @list{tmp == NULL})) { + @x = @(if offset + @list{(_offset ? tmp : @; + (@ctype)W_OFFSET(tmp, toff))} + "tmp"); + return NULL; + } else { + *basetype_p = FOREIGN_@cname; + return @(if offset + @list{_offset ? tmp : @; + (@ctype)W_OFFSET(tmp, toff)} + "tmp"); + }} + @list{@x = tmp@";" return NULL@";"}) + } else { + @wrong-type["val" stype]; + @hush + }}]))}) case FOREIGN_struct: if (!SCHEME_FFIANYPTRP(val)) scheme_wrong_type("Scheme->C", "pointer", 0, 1, &val); @@ -1144,8 +1135,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, /* C type information */ /* (ctype-sizeof type) -> int, returns 0 for void, error if not a C type */ -{:(cdefine ctype-sizeof 1):} -{ +@cdefine[ctype-sizeof 1]{ int size; size = ctype_sizeof(argv[0]); if (size >= 0) return scheme_make_integer(size); @@ -1154,8 +1144,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, } /* (ctype-alignof type) -> int, returns 0 for void, error if not a C type */ -{:(cdefine ctype-alignof 1):} -{ +@cdefine[ctype-alignof 1]{ Scheme_Object *type; type = get_ctype_base(argv[0]); if (type == NULL) scheme_wrong_type(MYNAME, "C-type", 0, argc, argv); @@ -1167,8 +1156,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, * The symbols are in 'int 'char 'void 'short 'long '*, order does not matter, * when a single symbol is used, a list is not needed. * (This is about actual C types, not C type objects.) */ -{:(cdefine compiler-sizeof 1):} -{ +@cdefine[compiler-sizeof 1]{ int res=0; int basetype = 0; /* 1=int, 2=char, 3=void, 4=float, 5=double */ int intsize = 0; /* "short" => decrement, "long" => increment */ @@ -1217,17 +1205,17 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, if (basetype == 0) basetype = 1; /* int is the default type */ /* don't assume anything, so it can be used to verify compiler assumptions */ /* (only forbid stuff that the compiler doesn't allow) */ -#define RETSIZE(t) res=((stars==0)?sizeof(t):sizeof(t *)) + @@DEFINE{RETSIZE(t) res=((stars==0)?sizeof(t):sizeof(t *))} switch (basetype) { case 1: /* int */ switch (intsize) { case 0: RETSIZE(int); break; case 1: RETSIZE(long int); break; -#ifdef INT64_AS_LONG_LONG + @@@IFDEF{INT64_AS_LONG_LONG}{ case 2: RETSIZE(_int64); break; /* MSVC doesn't allow long long */ -#else + }{ case 2: RETSIZE(long long int); break; -#endif + } case -1: RETSIZE(short int); break; } break; @@ -1252,15 +1240,15 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, scheme_signal_error(MYNAME": internal error (unexpected type %d)", basetype); } -#undef RETSIZE + @UNDEF{RETSIZE} return scheme_make_integer(res); } /*****************************************************************************/ /* Pointer type user functions */ -{:(defsymbols nonatomic atomic stubborn uncollectable eternal - interior atomic-interior raw fail-ok):} +@defsymbols[nonatomic atomic stubborn uncollectable eternal + interior atomic-interior raw fail-ok] /* (malloc num type cpointer mode) -> pointer */ /* The arguments for this function are: @@ -1276,8 +1264,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, * different types, the only requirement is for a size, either a number of * bytes or a type. If no mode is specified, then scheme_malloc will be used * when the type is any pointer, otherwise scheme_malloc_atomic is used. */ -{:(cdefine malloc 1 5):} -{ +@cdefine[malloc 1 5]{ int i, size=0, num=0, failok=0; void *from = NULL, *res = NULL; long foff = 0; @@ -1339,8 +1326,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, } /* (end-stubborn-change ptr) */ -{:(cdefine end-stubborn-change 1):} -{ +@cdefine[end-stubborn-change 1]{ void *ptr; long poff; if (!SCHEME_FFIANYPTRP(argv[0])) @@ -1356,8 +1342,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, /* (free ptr) */ /* This is useful for raw-malloced objects, including objects from C libraries * that the library is mallocing itself. */ -{:(cdefine free 1):} -{ +@cdefine[free 1]{ void *ptr; long poff; if (!SCHEME_FFIANYPTRP(argv[0])) @@ -1371,14 +1356,12 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, } /* (malloc-immobile-cell v) */ -{:(cdefine malloc-immobile-cell 1):} -{ +@cdefine[malloc-immobile-cell 1]{ return scheme_make_foreign_cpointer(scheme_malloc_immobile_box(argv[0])); } /* (free-immobile-cell b) */ -{:(cdefine free-immobile-cell 1):} -{ +@cdefine[free-immobile-cell 1]{ void *ptr; long poff; if (!SCHEME_FFIANYPTRP(argv[0])) @@ -1433,21 +1416,19 @@ static Scheme_Object *do_ptr_add(const char *who, int is_bang, } /* (ptr-add cptr offset-k [type]) */ -{:(cdefine ptr-add 2 3):} { return do_ptr_add(MYNAME, 0, argc, argv); } +@cdefine[ptr-add 2 3]{return do_ptr_add(MYNAME, 0, argc, argv);} /* (ptr-add! cptr offset-k [type]) */ -{:(cdefine ptr-add! 2 3):} { return do_ptr_add(MYNAME, 1, argc, argv); } +@cdefine[ptr-add! 2 3]{return do_ptr_add(MYNAME, 1, argc, argv);} /* (offset-ptr? x) */ /* Returns #t if the argument is a cpointer with an offset */ -{:(cdefine offset-ptr? 1 1):} -{ +@cdefine[offset-ptr? 1 1]{ return (SCHEME_CPOINTER_W_OFFSET_P(argv[0])) ? scheme_true : scheme_false; } /* (ptr-offset ptr) */ /* Returns the offset of a cpointer (0 if it's not an offset pointer) */ -{:(cdefine ptr-offset 1 1):} -{ +@cdefine[ptr-offset 1 1]{ if (!SCHEME_FFIANYPTRP(argv[0])) scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv); return scheme_make_integer_value(SCHEME_FFIANYPTR_OFFSET(argv[0])); @@ -1456,8 +1437,7 @@ static Scheme_Object *do_ptr_add(const char *who, int is_bang, /* (set-ptr-offset! ptr offset [type]) */ /* Sets the offset of an offset-cpointer (possibly multiplied by the size of * the given ctype) */ -{:(cdefine set-ptr-offset! 2 3):} -{ +@cdefine[set-ptr-offset! 2 3]{ long noff; if (!SCHEME_CPOINTER_W_OFFSET_P(argv[0])) scheme_wrong_type(MYNAME, "offset-cpointer", 0, argc, argv); @@ -1565,19 +1545,18 @@ static Scheme_Object *do_memop(const char *who, int mode, return scheme_void; } -{:(cdefine memset 3 5):} { return do_memop(MYNAME, 0, argc, argv); } -{:(cdefine memmove 3 6):} { return do_memop(MYNAME, 1, argc, argv); } -{:(cdefine memcpy 3 6):} { return do_memop(MYNAME, 2, argc, argv); } +@cdefine[memset 3 5]{return do_memop(MYNAME, 0, argc, argv);} +@cdefine[memmove 3 6]{return do_memop(MYNAME, 1, argc, argv);} +@cdefine[memcpy 3 6]{return do_memop(MYNAME, 2, argc, argv);} -{:(defsymbols abs):} +@defsymbols[abs] /* (ptr-ref cpointer type [['abs] n]) -> the object at the given location */ /* n defaults to 0 which is the only value that should be used with ffi_objs */ -/* if n is given, an 'abs flag can precede it to make n be a byte offset rather - * than some multiple of sizeof(type). */ +/* if n is given, an 'abs flag can precede it to make n be a byte offset */ +/* rather than some multiple of sizeof(type). */ /* WARNING: there are *NO* checks at all, this is raw C level code. */ -{:(cdefine ptr-ref 2 4):} -{ +@cdefine[ptr-ref 2 4]{ int size=0; void *ptr; Scheme_Object *base; long delta; @@ -1624,11 +1603,10 @@ static Scheme_Object *do_memop(const char *who, int mode, /* (ptr-set! cpointer type [['abs] n] value) -> void */ /* n defaults to 0 which is the only value that should be used with ffi_objs */ -/* if n is given, an 'abs flag can precede it to make n be a byte offset rather - * than some multiple of sizeof(type). */ +/* if n is given, an 'abs flag can precede it to make n be a byte offset */ +/* rather than some multiple of sizeof(type). */ /* WARNING: there are *NO* checks at all, this is raw C level code. */ -{:(cdefine ptr-set! 3 5):} -{ +@cdefine[ptr-set! 3 5]{ int size=0; void *ptr; long delta; Scheme_Object *val = argv[argc-1], *base; @@ -1667,8 +1645,7 @@ static Scheme_Object *do_memop(const char *who, int mode, } /* (ptr-equal? cpointer cpointer) -> boolean */ -{:(cdefine ptr-equal? 2 2):} -{ +@cdefine[ptr-equal? 2 2]{ if (!SCHEME_FFIANYPTRP(argv[0])) scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv); if (!SCHEME_FFIANYPTRP(argv[1])) @@ -1680,12 +1657,11 @@ static Scheme_Object *do_memop(const char *who, int mode, } /* (make-sized-byte-string cpointer len) */ -{:(cdefine make-sized-byte-string 2 2):} -/* Warning: no copying is done so it is possible to share string contents. */ -/* Warning: if source ptr has a offset, resulting string object uses shifted - * pointer. - * (Should use real byte-strings with new version.) */ -{ +@cdefine[make-sized-byte-string 2 2]{ + /* Warning: no copying is done so it is possible to share string contents. */ + /* Warning: if source ptr has a offset, resulting string object uses shifted + * pointer. + * (Should use real byte-strings with new version.) */ long len; if (!SCHEME_FFIANYPTRP(argv[0])) scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv); @@ -1729,10 +1705,9 @@ void do_ptr_finalizer(void *p, void *finalizer) /* unreachable, and it will get a new cpointer object that points to it. */ /* (Only needed in cases where pointer aliases might be created.) */ /* - -{:"(defsymbols pointer)":} -{:"(cdefine register-finalizer 2 3)":} -{ +@prefix[" * "]{ +defsymbols[pointer] +cdefine[register-finalizer 2 3]{ void *ptr, *old = NULL; int ptrsym = (argc == 3 && argv[2] == pointer_sym); if (ptrsym) { @@ -1752,8 +1727,8 @@ void do_ptr_finalizer(void *p, void *finalizer) (ptr, (ptrsym ? do_ptr_finalizer : do_scm_finalizer), argv[1], NULL, &old); return (old == NULL) ? scheme_false : (Scheme_Object*)old; -} -*/ +}} + */ /*****************************************************************************/ /* Calling foreign function objects */ @@ -1877,8 +1852,7 @@ void free_fficall_data(void *ignored, void *p) /* (ffi-call ffi-obj in-types out-type [abi]) -> (in-types -> out-value) */ /* the real work is done by ffi_do_call above */ -{:(cdefine ffi-call 3 4):} -{ +@cdefine[ffi-call 3 4]{ static Scheme_Object *ffi_name_prefix = NULL; Scheme_Object *itypes = argv[1]; Scheme_Object *otype = argv[2]; @@ -1996,8 +1970,7 @@ void free_cl_cif_args(void *ignored, void *p) /* (ffi-callback scheme-proc in-types out-type [abi]) -> ffi-callback */ /* the treatment of in-types and out-types is similar to that in ffi-call */ /* the real work is done by ffi_do_callback above */ -{:(cdefine ffi-callback 3 5):} -{ +@cdefine[ffi-callback 3 5]{ ffi_callback_struct *data; Scheme_Object *itypes = argv[1]; Scheme_Object *otype = argv[2]; @@ -2060,19 +2033,19 @@ void free_cl_cif_args(void *ignored, void *p) } if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK) scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK"); - {:(cmake-object "data" ffi-callback - "cl_cif_args" "argv[0]" "argv[1]" "argv[2]" - "((argc > 4) && SCHEME_TRUEP(argv[4]))"):} -#ifdef MZ_PRECISE_GC + @cmake["data" ffi-callback + "cl_cif_args" "argv[0]" "argv[1]" "argv[2]" + "((argc > 4) && SCHEME_TRUEP(argv[4]))"] + @@@IFDEF{MZ_PRECISE_GC}{ { /* put data in immobile, weak box */ void **tmp; tmp = GC_malloc_immobile_box(GC_malloc_weak_box(data, NULL, 0)); cl_cif_args->data = (struct immobile_box*)tmp; } -#else + }{ cl_cif_args->data = (void*)data; -#endif + } if (ffi_prep_closure(cl, cif, &ffi_do_callback, (void*)(cl_cif_args->data)) != FFI_OK) scheme_signal_error @@ -2112,38 +2085,37 @@ void scheme_init_foreign(Scheme_Env *env) ctype_struct *t; Scheme_Object *s; menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env); - {:(for-each (lambda (x) - (~ (cadr x)"_tag = scheme_make_type(\"<"(car x)">\");")) - (reverse cstructs)):} -#ifdef MZ_PRECISE_GC - {:(for-each (lambda (x) - (~ "GC_register_traversers("(cadr x)"_tag, "(cadr x)"_SIZE, " - (cadr x)"_MARK, " (cadr x)"_FIXUP, 1, 0);")) - (reverse cstructs)):} -#endif + @(maplines (lambda (x) + @list{@(cadr x)_tag = scheme_make_type("<@(car x)>")}) + (reverse (cstructs))) + @@IFDEF{MZ_PRECISE_GC}{ + @(maplines (lambda (x) + @list{GC_register_traversers(@(cadr x)_tag, @(cadr x)_SIZE, @; + @(cadr x)_MARK, @(cadr x)_FIXUP, 1, 0)}) + (reverse (cstructs))) + } scheme_set_type_printer(ctype_tag, ctype_printer); MZ_REGISTER_STATIC(opened_libs); opened_libs = scheme_make_hash_table(SCHEME_hash_string); - {:(for-each - (lambda (sym) - (~ "MZ_REGISTER_STATIC("(cadr sym)");" \\ - (cadr sym)" = scheme_intern_symbol(\""(car sym)"\");")) - (reverse symbols)):} - {:(for-each - (lambda (x) - (~ "scheme_add_global(\""(car x)"\"," \\ - " scheme_make_prim_w_arity(" - (cadr x)", \""(car x)"\", "(caddr x)", "(cadddr x)"), menv);")) - (reverse! cfunctions)) - (for-each-type - ;; no need for these, at least for now: - ;; (~ "MZ_REGISTER_STATIC("cname"_sym);" \\ - ;; cname"_sym = scheme_intern_symbol(\""stype"\");") - (~ "s = scheme_intern_symbol(\""stype"\");") - (cmake-object "t" ctype "s" - (list "(Scheme_Object*)(void*)(&ffi_type_"ftype")") - (list "(Scheme_Object*)FOREIGN_"cname)) - (~ "scheme_add_global(\"_"stype"\", (Scheme_Object*)t, menv);")):} + @(maplines (lambda (sym) + @list{MZ_REGISTER_STATIC(@(cadr sym)); + @(cadr sym) = scheme_intern_symbol("@(car sym)")}) + (reverse (symbols))) + @(maplines + (lambda (x) + (define-values (sname cfun min max) (apply values x)) + @list{scheme_add_global("@sname", + scheme_make_prim_w_arity(@cfun, "@sname", @min, @max), menv)}) + (reverse (cfunctions))) + @(map-types + ;; no need for these, at least for now: + ;; MZ_REGISTER_STATIC(@|cname|_sym); + ;; @|cname|_sym = scheme_intern_symbol("@stype"); + @list{s = scheme_intern_symbol("@stype"); + @cmake["t" ctype "s" + @list{(Scheme_Object*)(void*)(&ffi_type_@ftype)} + @list{(Scheme_Object*)FOREIGN_@cname}] + scheme_add_global("_@stype", (Scheme_Object*)t, menv)}) scheme_finish_primitive_module(menv); scheme_protect_primitive_provide(menv, NULL); } diff --git a/src/foreign/ssc-utils.ss b/src/foreign/ssc-utils.ss index 00427f0cea..632ea852ff 100644 --- a/src/foreign/ssc-utils.ss +++ b/src/foreign/ssc-utils.ss @@ -1,103 +1,147 @@ -;; Utilities for .ssc preprocessor files. +;; Preprocessor utilities for the .ssc file. -(define (~ . args) (apply show args) (newline*)) -(define \\ newline*) +#lang at-exp scheme/base -(define (seplist l sep) - (cdr (apply append (map (lambda (x) (list sep x)) l)))) -(define-syntax push! - (syntax-rules () [(push! x l) (set! l (cons x l))])) -(define-syntax pop! - (syntax-rules () [(pop! l) (begin0 (car l) (set! l (cdr l)))])) -(define (upcase x) - (list->string (map char-upcase (string->list (format "~a" x))))) +(require (for-syntax scheme/base) scheme/list scribble/text/output) +(provide maplines) +(define (maplines #:semicolons? [semi? #t] fun . ls) + (add-between + (apply filter-map (lambda xs + (let ([r (apply fun xs)]) + (cond [(list? r) (if semi? (append r '(";")) r)] + [(or (not r) (void? r)) #f] + [else (error 'maplines "bad result: ~e" r)]))) + ls) + "\n")) + +;; thunks are forced -- so this can be used as @@IFDEF{...}{...} too! +(provide IFDEF IFNDEF) +(define ((((IF*DEF token choose) . c) . t) . e) + (if (null? e) + @list{@verbatim{#}@token @c + @t + @verbatim{#}endif /* @c */} + @list{@verbatim{#}@token @c + @t + @verbatim{#}else /* @c @(choose '("undefined" . "defined")) */ + @e + @verbatim{#}endif /* @c */})) +(define IFDEF (IF*DEF "ifdef" car)) +(define IFNDEF (IF*DEF "ifndef" cdr)) + +(provide DEFINE UNDEF) +(define (DEFINE . t) @list{@verbatim{#}define @t}) +(define (UNDEF . t) @list{@verbatim{#}undef @t}) + +(provide scheme-id->c-name) (define (scheme-id->c-name str) - (let loop ([str (format "~a" str)] - [substs '((#rx"->" "_to_") (#rx"[-/]" "_") (#rx"\\*" "S") - (#rx"\\?$" "_p") (#rx"!$" "_bang"))]) - (if (null? substs) - str - (loop (regexp-replace* (caar substs) str (cadar substs)) (cdr substs))))) + (set! str (format "~a" str)) + (for ([subst '([#rx"->" "_to_"] [#rx"[-/]" "_"] [#rx"\\*" "S"] + [#rx"\\?$" "_p"] [#rx"!$" "_bang"])]) + (set! str (regexp-replace* (car subst) str (cadr subst)))) + str) + +;; Used to avoid bogus compilation errors +(provide hush) +(define hush @'{return NULL@";" /* hush the compiler */}) ;; User function definition -(define cfunctions '()) -(define (_cdefine name minargs . maxargs) - (define cname - (list "foreign_" (scheme-id->c-name name))) - (set! maxargs (if (null? maxargs) minargs (car maxargs))) - (push! (list name cname minargs maxargs) cfunctions) - (list "#undef MYNAME" \\ "#define MYNAME \""name"\""\\ - "static Scheme_Object *"cname"(int argc, Scheme_Object *argv[])"\\)) -(define-syntax cdefine - (syntax-rules () - [(_ name minargs maxargs) (_cdefine `name minargs maxargs)] - [(_ name args) (_cdefine `name args args)])) +(provide cfunctions) +(define cfunctions (make-parameter '())) +(define (_cdefine name minargs maxargs . body) + (define cname @list{foreign_@(scheme-id->c-name name)}) + (cfunctions (cons (list name cname minargs maxargs) (cfunctions))) + @list{@verbatim{#define MYNAME "@name"} + static Scheme_Object *@|cname|(int argc, Scheme_Object *argv[]) + { + @body + } + @verbatim{#undef MYNAME}}) +(provide cdefine) +(define-syntax (cdefine stx) + (syntax-case stx () + [(_ name minargs maxargs body ...) + (number? (syntax-e #'maxargs)) + #'(_cdefine `name minargs maxargs body ...)] + [(_ name args body ...) + #'(_cdefine `name args args body ...)])) ;; Struct definitions -(define cstructs '()) +(provide cstructs) +(define cstructs (make-parameter '())) (define (_cdefstruct name slots types) - (define cname - (regexp-replace* #rx"-" (symbol->string name) "_")) - (define mname - (list->string - (map char-upcase (string->list (regexp-replace* #rx"_" cname ""))))) - (define predname - (string->symbol (string-append (symbol->string name)"?"))) - (~ "/* "name" structure definition */") - (~ "static Scheme_Type "cname"_tag;" \\ - "typedef struct "cname"_struct {" \\ - " Scheme_Object so;") - (for-each (lambda (s t) (~ " "t" "s";")) slots types) - (~ "} "cname"_struct;" \\ - "#define SCHEME_"mname"P(x) (SCHEME_TYPE(x)=="cname"_tag)") - (~ (_cdefine predname 1) - "{ return SCHEME_"mname"P(argv[0]) ? scheme_true : scheme_false; }") - (~ "/* 3m stuff for "cname" */" \\ - "#ifdef MZ_PRECISE_GC" \\ - "START_XFORM_SKIP;" - "int "cname"_SIZE(void *p) {" \\ - " return gcBYTES_TO_WORDS(sizeof("cname"_struct));" \\ - "}") - (let ([mark/fix (lambda (mode) - (~ "int "cname"_"mode"(void *p) {" \\ - " "cname"_struct *s = ("cname"_struct *)p;") - (for-each (lambda (s t) - (when (regexp-match #rx"[*]" t) - (~ " gc"mode"(s->"s");"))) - slots types) - (~ " return gcBYTES_TO_WORDS(sizeof("cname"_struct));" \\ - "}"))]) - (mark/fix "MARK") - (mark/fix "FIXUP")) - (~ "END_XFORM_SKIP;" \\ - "#endif") - (push! (list* name cname slots) cstructs)) -(define-syntax cdefstruct - (syntax-rules () - [(_ name (slot type) ...) - (_cdefstruct `name (list `slot ...) (list type ...))])) + (define cname (regexp-replace* #rx"-" (symbol->string name) "_")) + (define mname (string-upcase (regexp-replace* #rx"_" cname ""))) + (define predname (string->symbol (format "~a?" name))) + (define (mark/fix mode) + @list{int @|cname|_@|mode|(void *p) { + @|cname|_struct *s = (@|cname|_struct *)p; + @(maplines (lambda (s t) + (when (regexp-match #rx"[*]" t) + @list{gc@|mode|(s->@s)})) + slots types) + return gcBYTES_TO_WORDS(sizeof(@|cname|_struct)); + }}) + (cstructs (cons (list* name cname slots) (cstructs))) + @list{/* @name structure definition */ + static Scheme_Type @|cname|_tag; + typedef struct @|cname|_struct { + Scheme_Object so; + @(maplines (lambda (s t) @list{@t @s}) slots types) + } @|cname|_struct; + #define SCHEME_@|mname|P(x) (SCHEME_TYPE(x)==@|cname|_tag) + @_cdefine[predname 1 1]{ + return SCHEME_@|mname|P(argv[0]) ? scheme_true : scheme_false@";" + } + /* 3m stuff for @cname */ + #ifdef MZ_PRECISE_GC + START_XFORM_SKIP; + int @|cname|_SIZE(void *p) { + return gcBYTES_TO_WORDS(sizeof(@|cname|_struct)); + } + @mark/fix{MARK} + @mark/fix{FIXUP} + END_XFORM_SKIP; + #endif}) +(provide cdefstruct) +(define-syntax-rule (cdefstruct name [slot type] ...) + (_cdefstruct `name (list `slot ...) (list type ...))) ;; Tagged object allocation -(define (_cmake-object var type . values) - (define cstruct (cdr (assq type cstructs))) - (~ var" = ("(car cstruct)"_struct*)scheme_malloc_tagged(sizeof(" - (car cstruct)"_struct));" \\ - var"->so.type = "(car cstruct)"_tag;") - (for-each (lambda (v f) (~ var"->"f" = ("v");")) values (cdr cstruct))) -(define-syntax cmake-object - (syntax-rules () [(_ var type val ...) (_cmake-object var `type val ...)])) +(define (_cmake var type . values) + (define cstruct (cdr (assq type (cstructs)))) + (define cname (car cstruct)) + @list{@var = (@|cname|_struct*)scheme_malloc_tagged(sizeof(@|cname|_struct)); + @|var|->so.type = @|cname|_tag; + @(maplines (lambda (v f) @list{@|var|->@f = (@v)}) + values (cdr cstruct))}) +(provide cmake) +(define-syntax-rule (cmake var type val ...) (_cmake var `type val ...)) ;; Pre-allocated symbols -(define symbols '()) +(provide symbols) +(define symbols (make-parameter '())) (define (add-symbols syms) - (map (lambda (s) - (when (assq s symbols) - (error 'add-symbols "symbol ~s already defined" s)) - (push! (list s (list (regexp-replace #rx"-" (symbol->string s) "_") - "_sym")) - symbols) - (list "static Scheme_Object *"(cadar symbols)";"\\)) - syms)) + (maplines (lambda (s) + (define new + @list{@(regexp-replace #rx"-" (symbol->string s) "_")_sym}) + (when (assq s (symbols)) + (error 'add-symbols "symbol ~s already defined" s)) + (symbols (cons (list s new) (symbols))) + @list{static Scheme_Object *@new}) + syms)) +(provide defsymbols) (define-syntax defsymbols (syntax-rules () [(_ sym ...) (add-symbols '(sym ...))])) + +;; warn against manual edits to the generated file +(provide header) +(define (header orig) + @list{/******************************************** + ** Do not edit this file! + ** This file is generated from @orig, + ** to make changes, edit that file and + ** run it to generate an updated version + ** of this file. + ********************************************/}) diff --git a/src/mzscheme/configure.ac b/src/mzscheme/configure.ac index e90eed7f25..87af1f2b53 100644 --- a/src/mzscheme/configure.ac +++ b/src/mzscheme/configure.ac @@ -722,12 +722,26 @@ AC_TRY_RUN( static inline int foo() { return 0; } int main() { return foo(); - }, inline=yes, inline=no, inline=no) + }, + inline=yes, inline=no, inline=no) if test "$inline" = "no" ; then MZOPTIONS="$MZOPTIONS -DNO_INLINE_KEYWORD" fi AC_MSG_RESULT($inline) +[ msg="for noinline attribute" ] +AC_MSG_CHECKING($msg) +AC_TRY_RUN( + static int foo() __attribute__ ((noinline)); + static int foo() { return 0; } + int main() { + return foo(); + }, noinline=yes, noinline=no, noinline=no) +if test "$noinline" = "yes" ; then + AC_DEFINE(MZ_USE_NOINLINE,1,[Have noinline attribute]) +fi +AC_MSG_RESULT($inline) + [ msg="for GNU preprocessor" ] AC_MSG_CHECKING($msg) AC_TRY_RUN( @@ -1439,8 +1453,12 @@ if test "${enable_mred}" = "yes" ; then makefiles="$makefiles mred/Makefile mred/wxs/Makefile mred/wxme/Makefile - mred/gc2/Makefile + mred/gc2/Makefile" + + if test "${enable_libpng}" != "yes" ; then + makefiles="$makefiles wxcommon/libpng/Makefile wxcommon/zlib/Makefile" + fi if test "${enable_quartz}" = "yes" ; then makefiles="$makefiles diff --git a/src/mzscheme/gc2/mem_account.c b/src/mzscheme/gc2/mem_account.c index 67eb15fe33..c9e9ba92e2 100644 --- a/src/mzscheme/gc2/mem_account.c +++ b/src/mzscheme/gc2/mem_account.c @@ -590,7 +590,7 @@ inline static void BTC_run_account_hooks(NewGC *gc) if( ((work->type == MZACCT_REQUIRE) && ((gc->used_pages > (gc->max_pages_for_use / 2)) || ((((gc->max_pages_for_use / 2) - gc->used_pages) * APAGE_SIZE) - < (work->amount + custodian_super_require(gc, work->c1))))) + < (work->amount + custodian_super_require(gc, work->c1))))) || ((work->type == MZACCT_LIMIT) && (GC_get_memory_use(work->c1) > work->amount))) { diff --git a/src/mzscheme/include/mzscheme.exp b/src/mzscheme/include/mzscheme.exp index ac24cae8e5..7c3ff49e19 100644 --- a/src/mzscheme/include/mzscheme.exp +++ b/src/mzscheme/include/mzscheme.exp @@ -562,6 +562,7 @@ scheme_get_seconds scheme_get_milliseconds scheme_get_inexact_milliseconds scheme_get_process_milliseconds +scheme_get_thread_milliseconds scheme_banner scheme_version scheme_check_proc_arity diff --git a/src/mzscheme/include/mzscheme3m.exp b/src/mzscheme/include/mzscheme3m.exp index ac6876fdc3..8a0104b167 100644 --- a/src/mzscheme/include/mzscheme3m.exp +++ b/src/mzscheme/include/mzscheme3m.exp @@ -574,6 +574,7 @@ scheme_get_seconds scheme_get_milliseconds scheme_get_inexact_milliseconds scheme_get_process_milliseconds +scheme_get_thread_milliseconds scheme_banner scheme_version scheme_check_proc_arity diff --git a/src/mzscheme/include/mzwin.def b/src/mzscheme/include/mzwin.def index e52df5313c..63c7fbd1a0 100644 --- a/src/mzscheme/include/mzwin.def +++ b/src/mzscheme/include/mzwin.def @@ -550,6 +550,7 @@ EXPORTS scheme_get_milliseconds scheme_get_inexact_milliseconds scheme_get_process_milliseconds + scheme_get_thread_milliseconds scheme_banner scheme_version scheme_check_proc_arity diff --git a/src/mzscheme/include/mzwin3m.def b/src/mzscheme/include/mzwin3m.def index 9e2f1bd4ef..c85242740b 100644 --- a/src/mzscheme/include/mzwin3m.def +++ b/src/mzscheme/include/mzwin3m.def @@ -566,6 +566,7 @@ EXPORTS scheme_get_milliseconds scheme_get_inexact_milliseconds scheme_get_process_milliseconds + scheme_get_thread_milliseconds scheme_banner scheme_version scheme_check_proc_arity diff --git a/src/mzscheme/include/scheme.h b/src/mzscheme/include/scheme.h index db193f31da..57fdb5866a 100644 --- a/src/mzscheme/include/scheme.h +++ b/src/mzscheme/include/scheme.h @@ -790,7 +790,7 @@ typedef struct { typedef struct Scheme_Hash_Table { - Scheme_Inclhash_Object iso; + Scheme_Inclhash_Object iso; /* 0x1 flag => marshal as #t (hack for stxobj bytecode) */ int size; /* power of 2 */ int count; Scheme_Object **keys; @@ -1024,6 +1024,7 @@ typedef struct Scheme_Thread { struct Scheme_Marshal_Tables *current_mt; Scheme_Object *constant_folding; /* compiler hack */ + Scheme_Object *reading_delayed; /* reader hack */ Scheme_Object *(*overflow_k)(void); Scheme_Object *overflow_reply; @@ -1078,6 +1079,10 @@ typedef struct Scheme_Thread { /* save thread-specific GMP state: */ long gmp_tls[6]; + void *gmp_tls_data; + + long accum_process_msec; + long current_start_process_msec; struct Scheme_Thread_Custodian_Hop *mr_hop; Scheme_Custodian_Reference *mref; diff --git a/src/mzscheme/mzconfig.h.in b/src/mzscheme/mzconfig.h.in index 2d7056aacd..425fd7b2f3 100644 --- a/src/mzscheme/mzconfig.h.in +++ b/src/mzscheme/mzconfig.h.in @@ -32,5 +32,7 @@ /* Whether getaddrinfo works. */ #undef HAVE_GETADDRINFO +/* Whether __attribute__ ((noinline)) works */ +#undef MZ_USE_NOINLINE #endif diff --git a/src/mzscheme/src/bignum.c b/src/mzscheme/src/bignum.c index 12fb65e68f..eec7d91266 100644 --- a/src/mzscheme/src/bignum.c +++ b/src/mzscheme/src/bignum.c @@ -887,6 +887,21 @@ Scheme_Object *do_big_power(const Scheme_Object *a, const Scheme_Object *b) Scheme_Object *scheme_generic_integer_power(const Scheme_Object *a, const Scheme_Object *b) { unsigned long exponent; + + if (scheme_current_thread->constant_folding) { + /* if we're trying to fold a constant, limit the work that we're willing to do at compile time */ + GC_CAN_IGNORE const char *too_big = "arguments too big to fold `expt'"; + if (SCHEME_BIGNUMP(b) + || (SCHEME_INT_VAL(b) > 10000)) + scheme_signal_error(too_big); + else if (SCHEME_BIGNUMP(a)) { + int len = SCHEME_BIGLEN(a); + if ((len > 10000) + || (len * SCHEME_INT_VAL(b)) > 10000) + scheme_signal_error(too_big); + } + } + if (scheme_get_unsigned_int_val((Scheme_Object *)b, &exponent)) return do_power(a, exponent); else diff --git a/src/mzscheme/src/cstartup.inc b/src/mzscheme/src/cstartup.inc index 57e3464d2a..2e1ecdac6b 100644 --- a/src/mzscheme/src/cstartup.inc +++ b/src/mzscheme/src/cstartup.inc @@ -1,5 +1,5 @@ { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,52,46,50,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,51,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, @@ -14,13 +14,13 @@ 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,134,228,94,159,2,15,35,35,159,2,14,35,35,16,20,2,3, +10,35,11,8,148,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, -134,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,134,228,16,0,97,10,37,11,8,134,228,16,0,13,16, +148,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,148,228,16,0,97,10,37,11,8,148,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,13,57,0,0,95,9,8,224,13,57,0,0, +8,29,8,28,8,27,93,8,224,27,57,0,0,95,9,8,224,27,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, @@ -29,16 +29,16 @@ 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,55,57,53,16,4,11,11,2,19,3,1,7, -101,110,118,57,55,57,54,93,8,224,14,57,0,0,95,9,8,224,14,57,0, +2,18,3,1,7,101,110,118,57,56,48,52,16,4,11,11,2,19,3,1,7, +101,110,118,57,56,48,53,93,8,224,28,57,0,0,95,9,8,224,28,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,55,57,56,16,4,11,11, -2,19,3,1,7,101,110,118,57,55,57,57,93,8,224,15,57,0,0,95,9, -8,224,15,57,0,0,2,1,248,22,135,4,193,27,248,22,135,4,194,249,22, +27,16,4,11,11,2,18,3,1,7,101,110,118,57,56,48,55,16,4,11,11, +2,19,3,1,7,101,110,118,57,56,48,56,93,8,224,29,57,0,0,95,9, +8,224,29,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, @@ -68,9 +68,9 @@ 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,50,49,16,4,11,11,2,19,3,1, -7,101,110,118,57,56,50,50,93,8,224,16,57,0,0,18,16,2,158,94,10, -64,118,111,105,100,8,47,95,9,8,224,16,57,0,0,2,1,27,248,22,67, +11,2,18,3,1,7,101,110,118,57,56,51,48,16,4,11,11,2,19,3,1, +7,101,110,118,57,56,51,49,93,8,224,30,57,0,0,18,16,2,158,94,10, +64,118,111,105,100,8,47,95,9,8,224,30,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, @@ -100,7 +100,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 2045); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,52,46,50,59,0,0,0,1,0,0,13,0,18,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,51,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, @@ -132,173 +132,173 @@ 116,101,32,115,116,114,105,110,103,6,36,36,99,97,110,110,111,116,32,97,100, 100,32,97,32,115,117,102,102,105,120,32,116,111,32,97,32,114,111,111,116,32, 112,97,116,104,58,32,5,0,27,20,14,159,80,158,36,50,250,80,158,39,51, -249,22,27,11,80,158,41,50,22,182,12,10,248,22,157,5,23,196,2,28,248, +249,22,27,11,80,158,41,50,22,184,12,10,248,22,157,5,23,196,2,28,248, 22,154,6,23,194,2,12,87,94,248,22,168,8,23,194,1,248,80,159,37,53, 36,195,28,248,22,73,23,195,2,9,27,248,22,66,23,196,2,27,28,248,22, -163,13,23,195,2,23,194,1,28,248,22,162,13,23,195,2,249,22,164,13,23, -196,1,250,80,158,42,48,248,22,178,13,2,19,11,10,250,80,158,40,48,248, -22,178,13,2,19,23,197,1,10,28,23,193,2,249,22,65,248,22,166,13,249, -22,164,13,23,198,1,247,22,179,13,27,248,22,67,23,200,1,28,248,22,73, -23,194,2,9,27,248,22,66,23,195,2,27,28,248,22,163,13,23,195,2,23, -194,1,28,248,22,162,13,23,195,2,249,22,164,13,23,196,1,250,80,158,47, -48,248,22,178,13,2,19,11,10,250,80,158,45,48,248,22,178,13,2,19,23, -197,1,10,28,23,193,2,249,22,65,248,22,166,13,249,22,164,13,23,198,1, -247,22,179,13,248,80,159,45,52,36,248,22,67,23,199,1,87,94,23,193,1, +165,13,23,195,2,23,194,1,28,248,22,164,13,23,195,2,249,22,166,13,23, +196,1,250,80,158,42,48,248,22,180,13,2,19,11,10,250,80,158,40,48,248, +22,180,13,2,19,23,197,1,10,28,23,193,2,249,22,65,248,22,168,13,249, +22,166,13,23,198,1,247,22,181,13,27,248,22,67,23,200,1,28,248,22,73, +23,194,2,9,27,248,22,66,23,195,2,27,28,248,22,165,13,23,195,2,23, +194,1,28,248,22,164,13,23,195,2,249,22,166,13,23,196,1,250,80,158,47, +48,248,22,180,13,2,19,11,10,250,80,158,45,48,248,22,180,13,2,19,23, +197,1,10,28,23,193,2,249,22,65,248,22,168,13,249,22,166,13,23,198,1, +247,22,181,13,248,80,159,45,52,36,248,22,67,23,199,1,87,94,23,193,1, 248,80,159,43,52,36,248,22,67,23,197,1,87,94,23,193,1,27,248,22,67, 23,198,1,28,248,22,73,23,194,2,9,27,248,22,66,23,195,2,27,28,248, -22,163,13,23,195,2,23,194,1,28,248,22,162,13,23,195,2,249,22,164,13, -23,196,1,250,80,158,45,48,248,22,178,13,2,19,11,10,250,80,158,43,48, -248,22,178,13,2,19,23,197,1,10,28,23,193,2,249,22,65,248,22,166,13, -249,22,164,13,23,198,1,247,22,179,13,248,80,159,43,52,36,248,22,67,23, -199,1,248,80,159,41,52,36,248,22,67,196,27,248,22,139,13,23,195,2,28, -23,193,2,192,87,94,23,193,1,28,248,22,159,6,23,195,2,27,248,22,161, -13,195,28,192,192,248,22,162,13,195,11,87,94,28,28,248,22,140,13,23,195, -2,10,27,248,22,139,13,23,196,2,28,23,193,2,192,87,94,23,193,1,28, -248,22,159,6,23,196,2,27,248,22,161,13,23,197,2,28,23,193,2,192,87, -94,23,193,1,248,22,162,13,23,197,2,11,12,250,22,132,9,76,110,111,114, +22,165,13,23,195,2,23,194,1,28,248,22,164,13,23,195,2,249,22,166,13, +23,196,1,250,80,158,45,48,248,22,180,13,2,19,11,10,250,80,158,43,48, +248,22,180,13,2,19,23,197,1,10,28,23,193,2,249,22,65,248,22,168,13, +249,22,166,13,23,198,1,247,22,181,13,248,80,159,43,52,36,248,22,67,23, +199,1,248,80,159,41,52,36,248,22,67,196,27,248,22,141,13,23,195,2,28, +23,193,2,192,87,94,23,193,1,28,248,22,159,6,23,195,2,27,248,22,163, +13,195,28,192,192,248,22,164,13,195,11,87,94,28,28,248,22,142,13,23,195, +2,10,27,248,22,141,13,23,196,2,28,23,193,2,192,87,94,23,193,1,28, +248,22,159,6,23,196,2,27,248,22,163,13,23,197,2,28,23,193,2,192,87, +94,23,193,1,248,22,164,13,23,197,2,11,12,250,22,132,9,76,110,111,114, 109,97,108,45,112,97,116,104,45,99,97,115,101,6,42,42,112,97,116,104,32, 40,102,111,114,32,97,110,121,32,115,121,115,116,101,109,41,32,111,114,32,118, 97,108,105,100,45,112,97,116,104,32,115,116,114,105,110,103,23,197,2,28,28, -248,22,140,13,23,195,2,249,22,164,8,248,22,141,13,23,197,2,2,20,249, +248,22,142,13,23,195,2,249,22,164,8,248,22,143,13,23,197,2,2,20,249, 22,164,8,247,22,178,7,2,20,27,28,248,22,159,6,23,196,2,23,195,2, -248,22,168,7,248,22,144,13,23,197,2,28,249,22,191,13,0,21,35,114,120, +248,22,168,7,248,22,146,13,23,197,2,28,249,22,129,14,0,21,35,114,120, 34,94,91,92,92,93,91,92,92,93,91,63,93,91,92,92,93,34,23,195,2, -28,248,22,159,6,195,248,22,147,13,195,194,27,248,22,134,7,23,195,1,249, -22,148,13,248,22,171,7,250,22,133,14,0,6,35,114,120,34,47,34,28,249, -22,191,13,0,22,35,114,120,34,91,47,92,92,93,91,46,32,93,43,91,47, -92,92,93,42,36,34,23,201,2,23,199,1,250,22,133,14,0,19,35,114,120, +28,248,22,159,6,195,248,22,149,13,195,194,27,248,22,134,7,23,195,1,249, +22,150,13,248,22,171,7,250,22,135,14,0,6,35,114,120,34,47,34,28,249, +22,129,14,0,22,35,114,120,34,91,47,92,92,93,91,46,32,93,43,91,47, +92,92,93,42,36,34,23,201,2,23,199,1,250,22,135,14,0,19,35,114,120, 34,91,32,46,93,43,40,91,47,92,92,93,42,41,36,34,23,202,1,6,2, -2,92,49,80,159,43,36,37,2,20,28,248,22,159,6,194,248,22,147,13,194, -193,87,94,28,27,248,22,139,13,23,196,2,28,23,193,2,192,87,94,23,193, -1,28,248,22,159,6,23,196,2,27,248,22,161,13,23,197,2,28,23,193,2, -192,87,94,23,193,1,248,22,162,13,23,197,2,11,12,250,22,132,9,23,196, -2,2,21,23,197,2,28,248,22,161,13,23,195,2,12,248,22,158,11,249,22, -167,10,248,22,188,6,250,22,143,7,2,22,23,200,1,23,201,1,247,22,23, -87,94,28,27,248,22,139,13,23,196,2,28,23,193,2,192,87,94,23,193,1, -28,248,22,159,6,23,196,2,27,248,22,161,13,23,197,2,28,23,193,2,192, -87,94,23,193,1,248,22,162,13,23,197,2,11,12,250,22,132,9,23,196,2, -2,21,23,197,2,28,248,22,161,13,23,195,2,12,248,22,158,11,249,22,167, +2,92,49,80,159,43,36,37,2,20,28,248,22,159,6,194,248,22,149,13,194, +193,87,94,28,27,248,22,141,13,23,196,2,28,23,193,2,192,87,94,23,193, +1,28,248,22,159,6,23,196,2,27,248,22,163,13,23,197,2,28,23,193,2, +192,87,94,23,193,1,248,22,164,13,23,197,2,11,12,250,22,132,9,23,196, +2,2,21,23,197,2,28,248,22,163,13,23,195,2,12,248,22,160,11,249,22, +169,10,248,22,188,6,250,22,143,7,2,22,23,200,1,23,201,1,247,22,23, +87,94,28,27,248,22,141,13,23,196,2,28,23,193,2,192,87,94,23,193,1, +28,248,22,159,6,23,196,2,27,248,22,163,13,23,197,2,28,23,193,2,192, +87,94,23,193,1,248,22,164,13,23,197,2,11,12,250,22,132,9,23,196,2, +2,21,23,197,2,28,248,22,163,13,23,195,2,12,248,22,160,11,249,22,169, 10,248,22,188,6,250,22,143,7,2,22,23,200,1,23,201,1,247,22,23,87, -94,87,94,28,27,248,22,139,13,23,196,2,28,23,193,2,192,87,94,23,193, -1,28,248,22,159,6,23,196,2,27,248,22,161,13,23,197,2,28,23,193,2, -192,87,94,23,193,1,248,22,162,13,23,197,2,11,12,250,22,132,9,195,2, -21,23,197,2,28,248,22,161,13,23,195,2,12,248,22,158,11,249,22,167,10, +94,87,94,28,27,248,22,141,13,23,196,2,28,23,193,2,192,87,94,23,193, +1,28,248,22,159,6,23,196,2,27,248,22,163,13,23,197,2,28,23,193,2, +192,87,94,23,193,1,248,22,164,13,23,197,2,11,12,250,22,132,9,195,2, +21,23,197,2,28,248,22,163,13,23,195,2,12,248,22,160,11,249,22,169,10, 248,22,188,6,250,22,143,7,2,22,199,23,201,1,247,22,23,249,22,3,89, -162,8,44,36,49,9,223,2,33,33,196,248,22,158,11,249,22,133,11,23,196, +162,8,44,36,49,9,223,2,33,33,196,248,22,160,11,249,22,135,11,23,196, 1,247,22,23,87,94,250,80,159,38,39,36,2,6,196,197,251,80,159,39,41, 36,2,6,32,0,89,162,8,44,36,44,9,222,33,35,197,198,32,37,89,162, 43,41,58,65,99,108,111,111,112,222,33,38,28,248,22,73,23,199,2,87,94, 23,198,1,248,23,196,1,251,22,143,7,2,23,23,199,1,28,248,22,73,23, -203,2,87,94,23,202,1,23,201,1,250,22,1,22,157,13,23,204,1,23,205, -1,23,198,1,27,249,22,157,13,248,22,66,23,202,2,23,199,2,28,248,22, -152,13,23,194,2,27,250,22,1,22,157,13,23,197,1,23,202,2,28,248,22, -152,13,23,194,2,192,87,94,23,193,1,27,248,22,67,23,202,1,28,248,22, +203,2,87,94,23,202,1,23,201,1,250,22,1,22,159,13,23,204,1,23,205, +1,23,198,1,27,249,22,159,13,248,22,66,23,202,2,23,199,2,28,248,22, +154,13,23,194,2,27,250,22,1,22,159,13,23,197,1,23,202,2,28,248,22, +154,13,23,194,2,192,87,94,23,193,1,27,248,22,67,23,202,1,28,248,22, 73,23,194,2,87,94,23,193,1,248,23,199,1,251,22,143,7,2,23,23,202, -1,28,248,22,73,23,206,2,87,94,23,205,1,23,204,1,250,22,1,22,157, -13,23,207,1,23,208,1,23,201,1,27,249,22,157,13,248,22,66,23,197,2, -23,202,2,28,248,22,152,13,23,194,2,27,250,22,1,22,157,13,23,197,1, -204,28,248,22,152,13,193,192,253,2,37,203,204,205,206,23,15,248,22,67,201, +1,28,248,22,73,23,206,2,87,94,23,205,1,23,204,1,250,22,1,22,159, +13,23,207,1,23,208,1,23,201,1,27,249,22,159,13,248,22,66,23,197,2, +23,202,2,28,248,22,154,13,23,194,2,27,250,22,1,22,159,13,23,197,1, +204,28,248,22,154,13,193,192,253,2,37,203,204,205,206,23,15,248,22,67,201, 253,2,37,202,203,204,205,206,248,22,67,200,87,94,23,193,1,27,248,22,67, 23,201,1,28,248,22,73,23,194,2,87,94,23,193,1,248,23,198,1,251,22, 143,7,2,23,23,201,1,28,248,22,73,23,205,2,87,94,23,204,1,23,203, -1,250,22,1,22,157,13,23,206,1,23,207,1,23,200,1,27,249,22,157,13, -248,22,66,23,197,2,23,201,2,28,248,22,152,13,23,194,2,27,250,22,1, -22,157,13,23,197,1,203,28,248,22,152,13,193,192,253,2,37,202,203,204,205, -206,248,22,67,201,253,2,37,201,202,203,204,205,248,22,67,200,27,247,22,180, -13,253,2,37,198,199,200,201,202,198,87,95,28,28,248,22,140,13,23,194,2, -10,27,248,22,139,13,23,195,2,28,23,193,2,192,87,94,23,193,1,28,248, -22,159,6,23,195,2,27,248,22,161,13,23,196,2,28,23,193,2,192,87,94, -23,193,1,248,22,162,13,23,196,2,11,12,252,22,132,9,23,200,2,2,24, +1,250,22,1,22,159,13,23,206,1,23,207,1,23,200,1,27,249,22,159,13, +248,22,66,23,197,2,23,201,2,28,248,22,154,13,23,194,2,27,250,22,1, +22,159,13,23,197,1,203,28,248,22,154,13,193,192,253,2,37,202,203,204,205, +206,248,22,67,201,253,2,37,201,202,203,204,205,248,22,67,200,27,247,22,182, +13,253,2,37,198,199,200,201,202,198,87,95,28,28,248,22,142,13,23,194,2, +10,27,248,22,141,13,23,195,2,28,23,193,2,192,87,94,23,193,1,28,248, +22,159,6,23,195,2,27,248,22,163,13,23,196,2,28,23,193,2,192,87,94, +23,193,1,248,22,164,13,23,196,2,11,12,252,22,132,9,23,200,2,2,24, 35,23,198,2,23,199,2,28,28,248,22,159,6,23,195,2,10,248,22,147,7, 23,195,2,87,94,23,194,1,12,252,22,132,9,23,200,2,2,25,36,23,198, -2,23,199,1,91,159,38,11,90,161,38,35,11,248,22,160,13,23,197,2,87, +2,23,199,1,91,159,38,11,90,161,38,35,11,248,22,162,13,23,197,2,87, 94,23,195,1,87,94,28,192,12,250,22,133,9,23,201,1,2,26,23,199,1, -249,22,7,194,195,91,159,37,11,90,161,37,35,11,87,95,28,28,248,22,140, -13,23,196,2,10,27,248,22,139,13,23,197,2,28,23,193,2,192,87,94,23, -193,1,28,248,22,159,6,23,197,2,27,248,22,161,13,23,198,2,28,23,193, -2,192,87,94,23,193,1,248,22,162,13,23,198,2,11,12,252,22,132,9,2, +249,22,7,194,195,91,159,37,11,90,161,37,35,11,87,95,28,28,248,22,142, +13,23,196,2,10,27,248,22,141,13,23,197,2,28,23,193,2,192,87,94,23, +193,1,28,248,22,159,6,23,197,2,27,248,22,163,13,23,198,2,28,23,193, +2,192,87,94,23,193,1,248,22,164,13,23,198,2,11,12,252,22,132,9,2, 9,2,24,35,23,200,2,23,201,2,28,28,248,22,159,6,23,197,2,10,248, 22,147,7,23,197,2,12,252,22,132,9,2,9,2,25,36,23,200,2,23,201, -2,91,159,38,11,90,161,38,35,11,248,22,160,13,23,199,2,87,94,23,195, +2,91,159,38,11,90,161,38,35,11,248,22,162,13,23,199,2,87,94,23,195, 1,87,94,28,192,12,250,22,133,9,2,9,2,26,23,201,2,249,22,7,194, -195,27,249,22,149,13,250,22,132,14,0,18,35,114,120,35,34,40,91,46,93, -91,94,46,93,42,124,41,36,34,248,22,145,13,23,201,1,28,248,22,159,6, -23,203,2,249,22,171,7,23,204,1,8,63,23,202,1,28,248,22,140,13,23, -199,2,248,22,141,13,23,199,1,87,94,23,198,1,247,22,142,13,28,248,22, -139,13,194,249,22,157,13,195,194,192,91,159,37,11,90,161,37,35,11,87,95, -28,28,248,22,140,13,23,196,2,10,27,248,22,139,13,23,197,2,28,23,193, -2,192,87,94,23,193,1,28,248,22,159,6,23,197,2,27,248,22,161,13,23, -198,2,28,23,193,2,192,87,94,23,193,1,248,22,162,13,23,198,2,11,12, +195,27,249,22,151,13,250,22,134,14,0,18,35,114,120,35,34,40,91,46,93, +91,94,46,93,42,124,41,36,34,248,22,147,13,23,201,1,28,248,22,159,6, +23,203,2,249,22,171,7,23,204,1,8,63,23,202,1,28,248,22,142,13,23, +199,2,248,22,143,13,23,199,1,87,94,23,198,1,247,22,144,13,28,248,22, +141,13,194,249,22,159,13,195,194,192,91,159,37,11,90,161,37,35,11,87,95, +28,28,248,22,142,13,23,196,2,10,27,248,22,141,13,23,197,2,28,23,193, +2,192,87,94,23,193,1,28,248,22,159,6,23,197,2,27,248,22,163,13,23, +198,2,28,23,193,2,192,87,94,23,193,1,248,22,164,13,23,198,2,11,12, 252,22,132,9,2,10,2,24,35,23,200,2,23,201,2,28,28,248,22,159,6, 23,197,2,10,248,22,147,7,23,197,2,12,252,22,132,9,2,10,2,25,36, -23,200,2,23,201,2,91,159,38,11,90,161,38,35,11,248,22,160,13,23,199, +23,200,2,23,201,2,91,159,38,11,90,161,38,35,11,248,22,162,13,23,199, 2,87,94,23,195,1,87,94,28,192,12,250,22,133,9,2,10,2,26,23,201, -2,249,22,7,194,195,27,249,22,149,13,249,22,157,7,250,22,133,14,0,9, -35,114,120,35,34,91,46,93,34,248,22,145,13,23,203,1,6,1,1,95,28, +2,249,22,7,194,195,27,249,22,151,13,249,22,157,7,250,22,135,14,0,9, +35,114,120,35,34,91,46,93,34,248,22,147,13,23,203,1,6,1,1,95,28, 248,22,159,6,23,202,2,249,22,171,7,23,203,1,8,63,23,201,1,28,248, -22,140,13,23,199,2,248,22,141,13,23,199,1,87,94,23,198,1,247,22,142, -13,28,248,22,139,13,194,249,22,157,13,195,194,192,249,247,22,190,4,194,11, -249,80,158,37,46,9,9,249,80,158,37,46,195,9,27,247,22,182,13,249,80, +22,142,13,23,199,2,248,22,143,13,23,199,1,87,94,23,198,1,247,22,144, +13,28,248,22,141,13,194,249,22,159,13,195,194,192,249,247,22,190,4,194,11, +249,80,158,37,46,9,9,249,80,158,37,46,195,9,27,247,22,184,13,249,80, 158,38,47,28,23,195,2,27,248,22,176,7,6,11,11,80,76,84,67,79,76, 76,69,67,84,83,28,192,192,6,0,0,6,0,0,27,28,23,196,1,250,22, -157,13,248,22,178,13,69,97,100,100,111,110,45,100,105,114,247,22,174,7,6, +159,13,248,22,180,13,69,97,100,100,111,110,45,100,105,114,247,22,174,7,6, 8,8,99,111,108,108,101,99,116,115,11,27,248,80,159,41,52,36,250,22,79, -23,203,1,248,22,75,248,22,178,13,72,99,111,108,108,101,99,116,115,45,100, +23,203,1,248,22,75,248,22,180,13,72,99,111,108,108,101,99,116,115,45,100, 105,114,23,204,1,28,23,194,2,249,22,65,23,196,1,23,195,1,192,32,47, -89,162,8,44,38,54,2,18,222,33,48,27,249,22,189,13,23,197,2,23,198, +89,162,8,44,38,54,2,18,222,33,48,27,249,22,191,13,23,197,2,23,198, 2,28,23,193,2,87,94,23,196,1,27,248,22,90,23,195,2,27,27,248,22, -99,23,197,1,27,249,22,189,13,23,201,2,23,196,2,28,23,193,2,87,94, +99,23,197,1,27,249,22,191,13,23,201,2,23,196,2,28,23,193,2,87,94, 23,194,1,27,248,22,90,23,195,2,27,250,2,47,23,203,2,23,204,1,248, 22,99,23,199,1,28,249,22,153,7,23,196,2,2,27,249,22,79,23,202,2, -194,249,22,65,248,22,148,13,23,197,1,23,195,1,87,95,23,199,1,23,193, +194,249,22,65,248,22,150,13,23,197,1,23,195,1,87,95,23,199,1,23,193, 1,28,249,22,153,7,23,196,2,2,27,249,22,79,23,200,2,9,249,22,65, -248,22,148,13,23,197,1,9,28,249,22,153,7,23,196,2,2,27,249,22,79, -197,194,87,94,23,196,1,249,22,65,248,22,148,13,23,197,1,194,87,94,23, +248,22,150,13,23,197,1,9,28,249,22,153,7,23,196,2,2,27,249,22,79, +197,194,87,94,23,196,1,249,22,65,248,22,150,13,23,197,1,194,87,94,23, 193,1,28,249,22,153,7,23,198,2,2,27,249,22,79,195,9,87,94,23,194, -1,249,22,65,248,22,148,13,23,199,1,9,87,95,28,28,248,22,147,7,194, +1,249,22,65,248,22,150,13,23,199,1,9,87,95,28,28,248,22,147,7,194, 10,248,22,159,6,194,12,250,22,132,9,2,13,6,21,21,98,121,116,101,32, 115,116,114,105,110,103,32,111,114,32,115,116,114,105,110,103,196,28,28,248,22, -74,195,249,22,4,22,139,13,196,11,12,250,22,132,9,2,13,6,13,13,108, +74,195,249,22,4,22,141,13,196,11,12,250,22,132,9,2,13,6,13,13,108, 105,115,116,32,111,102,32,112,97,116,104,115,197,250,2,47,197,195,28,248,22, 159,6,197,248,22,170,7,197,196,32,50,89,162,8,44,39,57,2,18,222,33, 53,32,51,89,162,8,44,38,54,70,102,111,117,110,100,45,101,120,101,99,222, -33,52,28,23,193,2,91,159,38,11,90,161,38,35,11,248,22,160,13,23,199, -2,87,95,23,195,1,23,194,1,27,28,23,198,2,27,248,22,165,13,23,201, -2,28,249,22,166,8,23,195,2,23,202,2,11,28,248,22,161,13,23,194,2, -250,2,51,23,201,2,23,202,2,249,22,157,13,23,200,2,23,198,1,250,2, +33,52,28,23,193,2,91,159,38,11,90,161,38,35,11,248,22,162,13,23,199, +2,87,95,23,195,1,23,194,1,27,28,23,198,2,27,248,22,167,13,23,201, +2,28,249,22,166,8,23,195,2,23,202,2,11,28,248,22,163,13,23,194,2, +250,2,51,23,201,2,23,202,2,249,22,159,13,23,200,2,23,198,1,250,2, 51,23,201,2,23,202,2,23,196,1,11,28,23,193,2,192,87,94,23,193,1, -27,28,248,22,139,13,23,196,2,27,249,22,157,13,23,198,2,23,201,2,28, -28,248,22,152,13,193,10,248,22,151,13,193,192,11,11,28,23,193,2,192,87, -94,23,193,1,28,23,199,2,11,27,248,22,165,13,23,202,2,28,249,22,166, -8,23,195,2,23,203,1,11,28,248,22,161,13,23,194,2,250,2,51,23,202, -1,23,203,1,249,22,157,13,23,201,1,23,198,1,250,2,51,201,202,195,194, -28,248,22,73,23,197,2,11,27,248,22,164,13,248,22,66,23,199,2,27,249, -22,157,13,23,196,1,23,197,2,28,248,22,151,13,23,194,2,250,2,51,198, +27,28,248,22,141,13,23,196,2,27,249,22,159,13,23,198,2,23,201,2,28, +28,248,22,154,13,193,10,248,22,153,13,193,192,11,11,28,23,193,2,192,87, +94,23,193,1,28,23,199,2,11,27,248,22,167,13,23,202,2,28,249,22,166, +8,23,195,2,23,203,1,11,28,248,22,163,13,23,194,2,250,2,51,23,202, +1,23,203,1,249,22,159,13,23,201,1,23,198,1,250,2,51,201,202,195,194, +28,248,22,73,23,197,2,11,27,248,22,166,13,248,22,66,23,199,2,27,249, +22,159,13,23,196,1,23,197,2,28,248,22,153,13,23,194,2,250,2,51,198, 199,195,87,94,23,193,1,27,248,22,67,23,200,1,28,248,22,73,23,194,2, -11,27,248,22,164,13,248,22,66,23,196,2,27,249,22,157,13,23,196,1,23, -200,2,28,248,22,151,13,23,194,2,250,2,51,201,202,195,87,94,23,193,1, -27,248,22,67,23,197,1,28,248,22,73,23,194,2,11,27,248,22,164,13,248, -22,66,195,27,249,22,157,13,23,196,1,202,28,248,22,151,13,193,250,2,51, -204,205,195,251,2,50,204,205,206,248,22,67,199,87,95,28,27,248,22,139,13, +11,27,248,22,166,13,248,22,66,23,196,2,27,249,22,159,13,23,196,1,23, +200,2,28,248,22,153,13,23,194,2,250,2,51,201,202,195,87,94,23,193,1, +27,248,22,67,23,197,1,28,248,22,73,23,194,2,11,27,248,22,166,13,248, +22,66,195,27,249,22,159,13,23,196,1,202,28,248,22,153,13,193,250,2,51, +204,205,195,251,2,50,204,205,206,248,22,67,199,87,95,28,27,248,22,141,13, 23,196,2,28,23,193,2,192,87,94,23,193,1,28,248,22,159,6,23,196,2, -27,248,22,161,13,23,197,2,28,23,193,2,192,87,94,23,193,1,248,22,162, +27,248,22,163,13,23,197,2,28,23,193,2,192,87,94,23,193,1,248,22,164, 13,23,197,2,11,12,250,22,132,9,2,14,6,25,25,112,97,116,104,32,111, 114,32,115,116,114,105,110,103,32,40,115,97,110,115,32,110,117,108,41,23,197, -2,28,28,23,195,2,28,27,248,22,139,13,23,197,2,28,23,193,2,192,87, -94,23,193,1,28,248,22,159,6,23,197,2,27,248,22,161,13,23,198,2,28, -23,193,2,192,87,94,23,193,1,248,22,162,13,23,198,2,11,248,22,161,13, +2,28,28,23,195,2,28,27,248,22,141,13,23,197,2,28,23,193,2,192,87, +94,23,193,1,28,248,22,159,6,23,197,2,27,248,22,163,13,23,198,2,28, +23,193,2,192,87,94,23,193,1,248,22,164,13,23,198,2,11,248,22,163,13, 23,196,2,11,10,12,250,22,132,9,2,14,6,29,29,35,102,32,111,114,32, 114,101,108,97,116,105,118,101,32,112,97,116,104,32,111,114,32,115,116,114,105, -110,103,23,198,2,28,28,248,22,161,13,23,195,2,91,159,38,11,90,161,38, -35,11,248,22,160,13,23,198,2,249,22,164,8,194,68,114,101,108,97,116,105, +110,103,23,198,2,28,28,248,22,163,13,23,195,2,91,159,38,11,90,161,38, +35,11,248,22,162,13,23,198,2,249,22,164,8,194,68,114,101,108,97,116,105, 118,101,11,27,248,22,176,7,6,4,4,80,65,84,72,251,2,50,23,199,1, 23,200,1,23,201,1,28,23,197,2,27,249,80,159,43,47,37,23,200,1,9, -28,249,22,164,8,247,22,178,7,2,20,249,22,65,248,22,148,13,5,1,46, -23,195,1,192,9,27,248,22,164,13,23,196,1,28,248,22,151,13,193,250,2, +28,249,22,164,8,247,22,178,7,2,20,249,22,65,248,22,150,13,5,1,46, +23,195,1,192,9,27,248,22,166,13,23,196,1,28,248,22,153,13,193,250,2, 51,198,199,195,11,250,80,158,38,48,196,197,11,250,80,158,38,48,196,11,11, 87,94,249,22,150,6,247,22,186,4,195,248,22,176,5,249,22,172,3,35,249, 22,156,3,197,198,27,28,23,197,2,87,95,23,196,1,23,195,1,23,197,1, -87,94,23,197,1,27,248,22,178,13,2,19,27,249,80,159,40,48,37,23,196, +87,94,23,197,1,27,248,22,180,13,2,19,27,249,80,159,40,48,37,23,196, 1,11,27,27,248,22,175,3,23,200,1,28,192,192,35,27,27,248,22,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, @@ -330,7 +330,7 @@ 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,185,13,248,22,170,7,27,28,249,22,164,8,247,22,178,7, +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, @@ -342,12 +342,12 @@ EVAL_ONE_SIZED_STR((char *)expr, 5009); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,52,46,50,8,0,0,0,1,0,0,6,0,19,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,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, 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,140,230,97,159,2,2,35,35, +37,107,101,114,110,101,108,11,98,10,35,11,8,154,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, @@ -360,12 +360,12 @@ EVAL_ONE_SIZED_STR((char *)expr, 294); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,52,46,50,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,51,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,196,1,241,1,5,2,34,2,65,2,121,2,131,2,178,2,188,2,195, -2,82,4,95,4,114,4,233,4,245,4,141,5,155,5,21,6,27,6,41,6, -68,6,153,6,155,6,221,6,166,12,225,12,3,13,0,0,138,15,0,0,70, +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,162,12,221,12,255,12,0,0,134,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, @@ -383,178 +383,178 @@ 45,109,111,100,117,108,101,45,110,97,109,101,45,114,101,115,111,108,118,101,114, 63,108,105,98,67,105,103,110,111,114,101,100,249,22,14,195,80,159,37,45,37, 249,80,159,37,48,36,195,10,27,28,23,195,2,28,249,22,164,8,23,197,2, -80,159,38,46,37,87,94,23,195,1,80,159,36,47,37,27,248,22,173,4,23, -197,2,28,248,22,139,13,23,194,2,91,159,38,11,90,161,38,35,11,248,22, -160,13,23,197,1,87,95,83,160,37,11,80,159,40,46,37,198,83,160,37,11, -80,159,40,47,37,192,192,11,11,28,23,193,2,192,87,94,23,193,1,27,247, -22,191,4,28,192,192,247,22,179,13,20,14,159,80,158,35,39,250,80,158,38, -40,249,22,27,11,80,158,40,39,22,191,4,28,248,22,139,13,23,198,2,23, -197,1,87,94,23,197,1,247,22,179,13,247,194,250,22,157,13,23,197,1,23, -199,1,249,80,158,42,38,23,198,1,2,17,252,22,157,13,23,199,1,23,201, -1,2,18,247,22,179,7,249,80,158,44,38,23,200,1,80,159,44,35,37,87, -94,23,194,1,27,250,22,174,13,196,11,32,0,89,162,8,44,35,40,9,222, -11,28,192,249,22,65,195,194,11,27,252,22,157,13,23,200,1,23,202,1,2, -18,247,22,179,7,249,80,158,45,38,23,201,1,80,159,45,35,37,27,250,22, -174,13,196,11,32,0,89,162,8,44,35,40,9,222,11,28,192,249,22,65,195, -194,11,249,247,22,184,13,248,22,66,195,195,27,250,22,157,13,23,198,1,23, -200,1,249,80,158,43,38,23,199,1,2,17,27,250,22,174,13,196,11,32,0, -89,162,8,44,35,40,9,222,11,28,192,249,22,65,195,194,11,249,247,22,189, -4,248,22,66,195,195,249,247,22,189,4,194,195,87,94,28,248,80,158,36,37, -23,195,2,12,250,22,132,9,77,108,111,97,100,47,117,115,101,45,99,111,109, -112,105,108,101,100,6,25,25,112,97,116,104,32,111,114,32,118,97,108,105,100, -45,112,97,116,104,32,115,116,114,105,110,103,23,197,2,91,159,41,11,90,161, -36,35,11,28,248,22,163,13,23,201,2,23,200,1,27,247,22,191,4,28,23, -193,2,249,22,164,13,23,203,1,23,195,1,200,90,161,38,36,11,248,22,160, -13,23,194,2,87,94,23,196,1,90,161,36,39,11,28,249,22,164,8,23,196, -2,68,114,101,108,97,116,105,118,101,87,94,23,194,1,2,16,23,194,1,90, -161,36,40,11,247,22,181,13,27,89,162,43,36,49,62,122,111,225,7,5,3, -33,27,27,89,162,43,36,51,9,225,8,6,4,33,28,27,249,22,5,89,162, -8,44,36,46,9,223,5,33,29,23,203,2,27,28,23,195,1,27,249,22,5, -89,162,8,44,36,52,9,225,13,11,9,33,30,23,205,2,27,28,23,196,2, -11,193,28,192,192,28,193,28,23,196,2,28,249,22,168,3,248,22,67,196,248, -22,67,23,199,2,193,11,11,11,11,28,23,193,2,249,80,159,47,54,36,202, -89,162,43,35,45,9,224,14,2,33,31,87,94,23,193,1,27,28,23,197,1, -27,249,22,5,83,158,39,20,97,94,89,162,8,44,36,50,9,225,14,12,10, -33,32,23,203,1,23,206,1,27,28,196,11,193,28,192,192,28,193,28,196,28, -249,22,168,3,248,22,67,196,248,22,67,199,193,11,11,11,11,28,192,249,80, -159,48,54,36,203,89,162,43,35,45,9,224,15,2,33,33,249,80,159,48,54, -36,203,89,162,43,35,44,9,224,15,7,33,34,32,36,89,162,8,44,36,54, -2,19,222,33,38,0,17,35,114,120,34,94,40,46,42,63,41,47,40,46,42, -41,36,34,27,249,22,189,13,2,37,23,196,2,28,23,193,2,87,94,23,194, -1,249,22,65,248,22,90,23,196,2,27,248,22,99,23,197,1,27,249,22,189, -13,2,37,23,196,2,28,23,193,2,87,94,23,194,1,249,22,65,248,22,90, -23,196,2,27,248,22,99,23,197,1,27,249,22,189,13,2,37,23,196,2,28, -23,193,2,87,94,23,194,1,249,22,65,248,22,90,23,196,2,248,2,36,248, -22,99,23,197,1,248,22,75,194,248,22,75,194,248,22,75,194,32,39,89,162, -43,36,54,2,19,222,33,40,28,248,22,73,248,22,67,23,195,2,249,22,7, -9,248,22,66,195,91,159,37,11,90,161,37,35,11,27,248,22,67,23,197,2, -28,248,22,73,248,22,67,23,195,2,249,22,7,9,248,22,66,195,91,159,37, -11,90,161,37,35,11,27,248,22,67,23,197,2,28,248,22,73,248,22,67,23, -195,2,249,22,7,9,248,22,66,195,91,159,37,11,90,161,37,35,11,248,2, -39,248,22,67,23,197,2,249,22,7,249,22,65,248,22,66,23,200,1,23,197, -1,195,249,22,7,249,22,65,248,22,66,23,200,1,23,197,1,195,249,22,7, -249,22,65,248,22,66,23,200,1,23,197,1,195,27,248,2,36,23,195,1,28, -194,192,248,2,39,193,87,95,28,248,22,171,4,195,12,250,22,132,9,2,20, -6,20,20,114,101,115,111,108,118,101,100,45,109,111,100,117,108,101,45,112,97, -116,104,197,28,24,193,2,248,24,194,1,195,87,94,23,193,1,12,27,27,250, -22,139,2,80,159,41,42,37,248,22,145,14,247,22,186,11,11,28,23,193,2, -192,87,94,23,193,1,27,247,22,123,87,94,250,22,137,2,80,159,42,42,37, -248,22,145,14,247,22,186,11,195,192,250,22,137,2,195,198,66,97,116,116,97, -99,104,251,211,197,198,199,10,28,192,250,22,131,9,11,196,195,248,22,129,9, -194,28,249,22,165,6,194,6,1,1,46,2,16,28,249,22,165,6,194,6,2, -2,46,46,62,117,112,192,28,249,22,166,8,248,22,67,23,200,2,23,197,1, -28,249,22,164,8,248,22,66,23,200,2,23,196,1,251,22,129,9,2,20,6, -26,26,99,121,99,108,101,32,105,110,32,108,111,97,100,105,110,103,32,97,116, -32,126,101,58,32,126,101,23,200,1,249,22,2,22,67,248,22,80,249,22,65, -23,206,1,23,202,1,12,12,247,192,20,14,159,80,159,39,44,37,249,22,65, -248,22,145,14,247,22,186,11,23,197,1,20,14,159,80,158,39,39,250,80,158, -42,40,249,22,27,11,80,158,44,39,22,153,4,23,196,1,249,247,22,190,4, -23,198,1,248,22,54,248,22,143,13,23,198,1,87,94,28,28,248,22,139,13, -23,197,2,10,248,22,177,4,23,197,2,12,28,23,198,2,250,22,131,9,11, -6,15,15,98,97,100,32,109,111,100,117,108,101,32,112,97,116,104,23,201,2, -250,22,132,9,2,20,6,19,19,109,111,100,117,108,101,45,112,97,116,104,32, -111,114,32,112,97,116,104,23,199,2,28,28,248,22,63,23,197,2,249,22,164, -8,248,22,66,23,199,2,2,3,11,248,22,172,4,248,22,90,197,28,28,248, -22,63,23,197,2,249,22,164,8,248,22,66,23,199,2,66,112,108,97,110,101, -116,11,87,94,28,207,12,20,14,159,80,158,37,39,250,80,158,40,40,249,22, -27,11,80,158,42,39,22,186,11,23,197,1,90,161,36,35,10,249,22,154,4, -21,94,2,21,6,18,18,112,108,97,110,101,116,47,114,101,115,111,108,118,101, -114,46,115,115,1,27,112,108,97,110,101,116,45,109,111,100,117,108,101,45,110, -97,109,101,45,114,101,115,111,108,118,101,114,12,251,211,199,200,201,202,87,94, -23,193,1,27,89,162,8,44,36,45,79,115,104,111,119,45,99,111,108,108,101, -99,116,105,111,110,45,101,114,114,223,6,33,44,27,28,248,22,53,23,199,2, -27,250,22,139,2,80,159,43,43,37,249,22,65,23,204,2,247,22,180,13,11, -28,23,193,2,192,87,94,23,193,1,91,159,37,11,90,161,37,35,11,249,80, -159,44,48,36,248,22,56,23,204,2,11,27,251,80,158,47,50,2,20,23,202, -1,28,248,22,73,23,199,2,23,199,2,248,22,66,23,199,2,28,248,22,73, -23,199,2,9,248,22,67,23,199,2,249,22,157,13,23,195,1,28,248,22,73, -23,197,1,87,94,23,197,1,6,7,7,109,97,105,110,46,115,115,249,22,182, -6,23,199,1,6,3,3,46,115,115,28,248,22,159,6,23,199,2,87,94,23, -194,1,27,248,80,159,41,55,36,23,201,2,27,250,22,139,2,80,159,44,43, -37,249,22,65,23,205,2,23,199,2,11,28,23,193,2,192,87,94,23,193,1, -91,159,37,11,90,161,37,35,11,249,80,159,45,48,36,23,204,2,11,250,22, -1,22,157,13,23,199,1,249,22,79,249,22,2,32,0,89,162,8,44,36,43, -9,222,33,45,23,200,1,248,22,75,23,200,1,28,248,22,139,13,23,199,2, -87,94,23,194,1,28,248,22,162,13,23,199,2,23,198,2,248,22,75,6,26, -26,32,40,97,32,112,97,116,104,32,109,117,115,116,32,98,101,32,97,98,115, -111,108,117,116,101,41,28,249,22,164,8,248,22,66,23,201,2,2,21,27,250, -22,139,2,80,159,43,43,37,249,22,65,23,204,2,247,22,180,13,11,28,23, -193,2,192,87,94,23,193,1,91,159,38,11,90,161,37,35,11,249,80,159,45, -48,36,248,22,90,23,205,2,11,90,161,36,37,11,28,248,22,73,248,22,92, -23,204,2,28,248,22,73,23,194,2,249,22,191,13,0,8,35,114,120,34,91, -46,93,34,23,196,2,11,10,27,27,28,23,197,2,249,22,79,28,248,22,73, -248,22,92,23,208,2,21,93,6,5,5,109,122,108,105,98,249,22,1,22,79, -249,22,2,80,159,51,56,36,248,22,92,23,211,2,23,197,2,28,248,22,73, -23,196,2,248,22,75,23,197,2,23,195,2,251,80,158,49,50,2,20,23,204, -1,248,22,66,23,198,2,248,22,67,23,198,1,249,22,157,13,23,195,1,28, -23,198,1,87,94,23,196,1,23,197,1,28,248,22,73,23,197,1,87,94,23, -197,1,6,7,7,109,97,105,110,46,115,115,28,249,22,191,13,0,8,35,114, -120,34,91,46,93,34,23,199,2,23,197,1,249,22,182,6,23,199,1,6,3, -3,46,115,115,28,249,22,164,8,248,22,66,23,201,2,64,102,105,108,101,249, -22,164,13,248,22,168,13,248,22,90,23,202,2,248,80,159,42,55,36,23,202, -2,12,87,94,28,28,248,22,139,13,23,194,2,10,248,22,181,7,23,194,2, -87,94,23,200,1,12,28,23,200,2,250,22,131,9,67,114,101,113,117,105,114, -101,249,22,143,7,6,17,17,98,97,100,32,109,111,100,117,108,101,32,112,97, -116,104,126,97,28,23,198,2,248,22,66,23,199,2,6,0,0,23,203,1,87, -94,23,200,1,250,22,132,9,2,20,249,22,143,7,6,13,13,109,111,100,117, -108,101,32,112,97,116,104,126,97,28,23,198,2,248,22,66,23,199,2,6,0, -0,23,201,2,27,28,248,22,181,7,23,195,2,249,22,186,7,23,196,2,35, -249,22,166,13,248,22,167,13,23,197,2,11,27,28,248,22,181,7,23,196,2, -249,22,186,7,23,197,2,36,248,80,158,42,51,23,195,2,91,159,38,11,90, -161,38,35,11,28,248,22,181,7,23,199,2,250,22,7,2,22,249,22,186,7, -23,203,2,37,2,22,248,22,160,13,23,198,2,87,95,23,195,1,23,193,1, -27,28,248,22,181,7,23,200,2,249,22,186,7,23,201,2,38,249,80,158,47, -52,23,197,2,5,0,27,28,248,22,181,7,23,201,2,249,22,186,7,23,202, -2,39,248,22,172,4,23,200,2,27,27,250,22,139,2,80,159,51,42,37,248, -22,145,14,247,22,186,11,11,28,23,193,2,192,87,94,23,193,1,27,247,22, -123,87,94,250,22,137,2,80,159,52,42,37,248,22,145,14,247,22,186,11,195, -192,87,95,28,23,209,1,27,250,22,139,2,23,197,2,197,11,28,23,193,1, -12,87,95,27,27,28,248,22,17,80,159,51,45,37,80,159,50,45,37,247,22, -19,250,22,25,248,22,23,23,197,2,80,159,53,44,37,23,196,1,27,248,22, -145,14,247,22,186,11,249,22,3,83,158,39,20,97,94,89,162,8,44,36,54, -9,226,12,11,2,3,33,46,23,195,1,23,196,1,248,28,248,22,17,80,159, -50,45,37,32,0,89,162,43,36,41,9,222,33,47,80,159,49,57,36,89,162, -43,35,50,9,227,14,9,8,4,3,33,48,250,22,137,2,23,197,1,197,10, -12,28,28,248,22,181,7,23,202,1,11,27,248,22,159,6,23,208,2,28,192, -192,28,248,22,63,23,208,2,249,22,164,8,248,22,66,23,210,2,2,21,11, -250,22,137,2,80,159,50,43,37,28,248,22,159,6,23,210,2,249,22,65,23, -211,1,248,80,159,53,55,36,23,213,1,87,94,23,210,1,249,22,65,23,211, -1,247,22,180,13,252,22,183,7,23,208,1,23,207,1,23,205,1,23,203,1, -201,12,193,91,159,37,10,90,161,36,35,10,11,90,161,36,36,10,83,158,38, -20,96,96,2,20,89,162,8,44,36,50,9,224,2,0,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,186,11,248,22,190,4,80,159, -36,36,37,248,22,177,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,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,4,30,2,5,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,2,6,2,7,2,8,2,9,2,10,2,11,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, 4103); +80,158,38,46,87,94,23,195,1,80,158,36,47,27,248,22,173,4,23,197,2, +28,248,22,141,13,23,194,2,91,159,38,11,90,161,38,35,11,248,22,162,13, +23,197,1,87,95,83,160,37,11,80,158,40,46,198,83,160,37,11,80,158,40, +47,192,192,11,11,28,23,193,2,192,87,94,23,193,1,27,247,22,191,4,28, +192,192,247,22,181,13,20,14,159,80,158,35,39,250,80,158,38,40,249,22,27, +11,80,158,40,39,22,191,4,28,248,22,141,13,23,198,2,23,197,1,87,94, +23,197,1,247,22,181,13,247,194,250,22,159,13,23,197,1,23,199,1,249,80, +158,42,38,23,198,1,2,17,252,22,159,13,23,199,1,23,201,1,2,18,247, +22,179,7,249,80,158,44,38,23,200,1,80,159,44,35,37,87,94,23,194,1, +27,250,22,176,13,196,11,32,0,89,162,8,44,35,40,9,222,11,28,192,249, +22,65,195,194,11,27,252,22,159,13,23,200,1,23,202,1,2,18,247,22,179, +7,249,80,158,45,38,23,201,1,80,159,45,35,37,27,250,22,176,13,196,11, +32,0,89,162,8,44,35,40,9,222,11,28,192,249,22,65,195,194,11,249,247, +22,186,13,248,22,66,195,195,27,250,22,159,13,23,198,1,23,200,1,249,80, +158,43,38,23,199,1,2,17,27,250,22,176,13,196,11,32,0,89,162,8,44, +35,40,9,222,11,28,192,249,22,65,195,194,11,249,247,22,189,4,248,22,66, +195,195,249,247,22,189,4,194,195,87,94,28,248,80,158,36,37,23,195,2,12, +250,22,132,9,77,108,111,97,100,47,117,115,101,45,99,111,109,112,105,108,101, +100,6,25,25,112,97,116,104,32,111,114,32,118,97,108,105,100,45,112,97,116, +104,32,115,116,114,105,110,103,23,197,2,91,159,41,11,90,161,36,35,11,28, +248,22,165,13,23,201,2,23,200,1,27,247,22,191,4,28,23,193,2,249,22, +166,13,23,203,1,23,195,1,200,90,161,38,36,11,248,22,162,13,23,194,2, +87,94,23,196,1,90,161,36,39,11,28,249,22,164,8,23,196,2,68,114,101, +108,97,116,105,118,101,87,94,23,194,1,2,16,23,194,1,90,161,36,40,11, +247,22,183,13,27,89,162,43,36,49,62,122,111,225,7,5,3,33,27,27,89, +162,43,36,51,9,225,8,6,4,33,28,27,249,22,5,89,162,8,44,36,46, +9,223,5,33,29,23,203,2,27,28,23,195,1,27,249,22,5,89,162,8,44, +36,52,9,225,13,11,9,33,30,23,205,2,27,28,23,196,2,11,193,28,192, +192,28,193,28,23,196,2,28,249,22,168,3,248,22,67,196,248,22,67,23,199, +2,193,11,11,11,11,28,23,193,2,249,80,159,47,54,36,202,89,162,43,35, +45,9,224,14,2,33,31,87,94,23,193,1,27,28,23,197,1,27,249,22,5, +83,158,39,20,97,94,89,162,8,44,36,50,9,225,14,12,10,33,32,23,203, +1,23,206,1,27,28,196,11,193,28,192,192,28,193,28,196,28,249,22,168,3, +248,22,67,196,248,22,67,199,193,11,11,11,11,28,192,249,80,159,48,54,36, +203,89,162,43,35,45,9,224,15,2,33,33,249,80,159,48,54,36,203,89,162, +43,35,44,9,224,15,7,33,34,32,36,89,162,8,44,36,54,2,19,222,33, +38,0,17,35,114,120,34,94,40,46,42,63,41,47,40,46,42,41,36,34,27, +249,22,191,13,2,37,23,196,2,28,23,193,2,87,94,23,194,1,249,22,65, +248,22,90,23,196,2,27,248,22,99,23,197,1,27,249,22,191,13,2,37,23, +196,2,28,23,193,2,87,94,23,194,1,249,22,65,248,22,90,23,196,2,27, +248,22,99,23,197,1,27,249,22,191,13,2,37,23,196,2,28,23,193,2,87, +94,23,194,1,249,22,65,248,22,90,23,196,2,248,2,36,248,22,99,23,197, +1,248,22,75,194,248,22,75,194,248,22,75,194,32,39,89,162,43,36,54,2, +19,222,33,40,28,248,22,73,248,22,67,23,195,2,249,22,7,9,248,22,66, +195,91,159,37,11,90,161,37,35,11,27,248,22,67,23,197,2,28,248,22,73, +248,22,67,23,195,2,249,22,7,9,248,22,66,195,91,159,37,11,90,161,37, +35,11,27,248,22,67,23,197,2,28,248,22,73,248,22,67,23,195,2,249,22, +7,9,248,22,66,195,91,159,37,11,90,161,37,35,11,248,2,39,248,22,67, +23,197,2,249,22,7,249,22,65,248,22,66,23,200,1,23,197,1,195,249,22, +7,249,22,65,248,22,66,23,200,1,23,197,1,195,249,22,7,249,22,65,248, +22,66,23,200,1,23,197,1,195,27,248,2,36,23,195,1,28,194,192,248,2, +39,193,87,95,28,248,22,171,4,195,12,250,22,132,9,2,20,6,20,20,114, +101,115,111,108,118,101,100,45,109,111,100,117,108,101,45,112,97,116,104,197,28, +24,193,2,248,24,194,1,195,87,94,23,193,1,12,27,27,250,22,139,2,80, +159,41,42,37,248,22,147,14,247,22,188,11,11,28,23,193,2,192,87,94,23, +193,1,27,247,22,123,87,94,250,22,137,2,80,159,42,42,37,248,22,147,14, +247,22,188,11,195,192,250,22,137,2,195,198,66,97,116,116,97,99,104,251,211, +197,198,199,10,28,192,250,22,131,9,11,196,195,248,22,129,9,194,28,249,22, +165,6,194,6,1,1,46,2,16,28,249,22,165,6,194,6,2,2,46,46,62, +117,112,192,28,249,22,166,8,248,22,67,23,200,2,23,197,1,28,249,22,164, +8,248,22,66,23,200,2,23,196,1,251,22,129,9,2,20,6,26,26,99,121, +99,108,101,32,105,110,32,108,111,97,100,105,110,103,32,97,116,32,126,101,58, +32,126,101,23,200,1,249,22,2,22,67,248,22,80,249,22,65,23,206,1,23, +202,1,12,12,247,192,20,14,159,80,159,39,44,37,249,22,65,248,22,147,14, +247,22,188,11,23,197,1,20,14,159,80,158,39,39,250,80,158,42,40,249,22, +27,11,80,158,44,39,22,153,4,23,196,1,249,247,22,190,4,23,198,1,248, +22,54,248,22,145,13,23,198,1,87,94,28,28,248,22,141,13,23,197,2,10, +248,22,177,4,23,197,2,12,28,23,198,2,250,22,131,9,11,6,15,15,98, +97,100,32,109,111,100,117,108,101,32,112,97,116,104,23,201,2,250,22,132,9, +2,20,6,19,19,109,111,100,117,108,101,45,112,97,116,104,32,111,114,32,112, +97,116,104,23,199,2,28,28,248,22,63,23,197,2,249,22,164,8,248,22,66, +23,199,2,2,3,11,248,22,172,4,248,22,90,197,28,28,248,22,63,23,197, +2,249,22,164,8,248,22,66,23,199,2,66,112,108,97,110,101,116,11,87,94, +28,207,12,20,14,159,80,158,37,39,250,80,158,40,40,249,22,27,11,80,158, +42,39,22,188,11,23,197,1,90,161,36,35,10,249,22,154,4,21,94,2,21, +6,18,18,112,108,97,110,101,116,47,114,101,115,111,108,118,101,114,46,115,115, +1,27,112,108,97,110,101,116,45,109,111,100,117,108,101,45,110,97,109,101,45, +114,101,115,111,108,118,101,114,12,251,211,199,200,201,202,87,94,23,193,1,27, +89,162,8,44,36,45,79,115,104,111,119,45,99,111,108,108,101,99,116,105,111, +110,45,101,114,114,223,6,33,44,27,28,248,22,53,23,199,2,27,250,22,139, +2,80,159,43,43,37,249,22,65,23,204,2,247,22,182,13,11,28,23,193,2, +192,87,94,23,193,1,91,159,37,11,90,161,37,35,11,249,80,159,44,48,36, +248,22,56,23,204,2,11,27,251,80,158,47,50,2,20,23,202,1,28,248,22, +73,23,199,2,23,199,2,248,22,66,23,199,2,28,248,22,73,23,199,2,9, +248,22,67,23,199,2,249,22,159,13,23,195,1,28,248,22,73,23,197,1,87, +94,23,197,1,6,7,7,109,97,105,110,46,115,115,249,22,182,6,23,199,1, +6,3,3,46,115,115,28,248,22,159,6,23,199,2,87,94,23,194,1,27,248, +80,159,41,55,36,23,201,2,27,250,22,139,2,80,159,44,43,37,249,22,65, +23,205,2,23,199,2,11,28,23,193,2,192,87,94,23,193,1,91,159,37,11, +90,161,37,35,11,249,80,159,45,48,36,23,204,2,11,250,22,1,22,159,13, +23,199,1,249,22,79,249,22,2,32,0,89,162,8,44,36,43,9,222,33,45, +23,200,1,248,22,75,23,200,1,28,248,22,141,13,23,199,2,87,94,23,194, +1,28,248,22,164,13,23,199,2,23,198,2,248,22,75,6,26,26,32,40,97, +32,112,97,116,104,32,109,117,115,116,32,98,101,32,97,98,115,111,108,117,116, +101,41,28,249,22,164,8,248,22,66,23,201,2,2,21,27,250,22,139,2,80, +159,43,43,37,249,22,65,23,204,2,247,22,182,13,11,28,23,193,2,192,87, +94,23,193,1,91,159,38,11,90,161,37,35,11,249,80,159,45,48,36,248,22, +90,23,205,2,11,90,161,36,37,11,28,248,22,73,248,22,92,23,204,2,28, +248,22,73,23,194,2,249,22,129,14,0,8,35,114,120,34,91,46,93,34,23, +196,2,11,10,27,27,28,23,197,2,249,22,79,28,248,22,73,248,22,92,23, +208,2,21,93,6,5,5,109,122,108,105,98,249,22,1,22,79,249,22,2,80, +159,51,56,36,248,22,92,23,211,2,23,197,2,28,248,22,73,23,196,2,248, +22,75,23,197,2,23,195,2,251,80,158,49,50,2,20,23,204,1,248,22,66, +23,198,2,248,22,67,23,198,1,249,22,159,13,23,195,1,28,23,198,1,87, +94,23,196,1,23,197,1,28,248,22,73,23,197,1,87,94,23,197,1,6,7, +7,109,97,105,110,46,115,115,28,249,22,129,14,0,8,35,114,120,34,91,46, +93,34,23,199,2,23,197,1,249,22,182,6,23,199,1,6,3,3,46,115,115, +28,249,22,164,8,248,22,66,23,201,2,64,102,105,108,101,249,22,166,13,248, +22,170,13,248,22,90,23,202,2,248,80,159,42,55,36,23,202,2,12,87,94, +28,28,248,22,141,13,23,194,2,10,248,22,181,7,23,194,2,87,94,23,200, +1,12,28,23,200,2,250,22,131,9,67,114,101,113,117,105,114,101,249,22,143, +7,6,17,17,98,97,100,32,109,111,100,117,108,101,32,112,97,116,104,126,97, +28,23,198,2,248,22,66,23,199,2,6,0,0,23,203,1,87,94,23,200,1, +250,22,132,9,2,20,249,22,143,7,6,13,13,109,111,100,117,108,101,32,112, +97,116,104,126,97,28,23,198,2,248,22,66,23,199,2,6,0,0,23,201,2, +27,28,248,22,181,7,23,195,2,249,22,186,7,23,196,2,35,249,22,168,13, +248,22,169,13,23,197,2,11,27,28,248,22,181,7,23,196,2,249,22,186,7, +23,197,2,36,248,80,158,42,51,23,195,2,91,159,38,11,90,161,38,35,11, +28,248,22,181,7,23,199,2,250,22,7,2,22,249,22,186,7,23,203,2,37, +2,22,248,22,162,13,23,198,2,87,95,23,195,1,23,193,1,27,28,248,22, +181,7,23,200,2,249,22,186,7,23,201,2,38,249,80,158,47,52,23,197,2, +5,0,27,28,248,22,181,7,23,201,2,249,22,186,7,23,202,2,39,248,22, +172,4,23,200,2,27,27,250,22,139,2,80,159,51,42,37,248,22,147,14,247, +22,188,11,11,28,23,193,2,192,87,94,23,193,1,27,247,22,123,87,94,250, +22,137,2,80,159,52,42,37,248,22,147,14,247,22,188,11,195,192,87,95,28, +23,209,1,27,250,22,139,2,23,197,2,197,11,28,23,193,1,12,87,95,27, +27,28,248,22,17,80,159,51,45,37,80,159,50,45,37,247,22,19,250,22,25, +248,22,23,23,197,2,80,159,53,44,37,23,196,1,27,248,22,147,14,247,22, +188,11,249,22,3,83,158,39,20,97,94,89,162,8,44,36,54,9,226,12,11, +2,3,33,46,23,195,1,23,196,1,248,28,248,22,17,80,159,50,45,37,32, +0,89,162,43,36,41,9,222,33,47,80,159,49,57,36,89,162,43,35,50,9, +227,14,9,8,4,3,33,48,250,22,137,2,23,197,1,197,10,12,28,28,248, +22,181,7,23,202,1,11,27,248,22,159,6,23,208,2,28,192,192,28,248,22, +63,23,208,2,249,22,164,8,248,22,66,23,210,2,2,21,11,250,22,137,2, +80,159,50,43,37,28,248,22,159,6,23,210,2,249,22,65,23,211,1,248,80, +159,53,55,36,23,213,1,87,94,23,210,1,249,22,65,23,211,1,247,22,182, +13,252,22,183,7,23,208,1,23,207,1,23,205,1,23,203,1,201,12,193,91, +159,37,10,90,161,36,35,10,11,90,161,36,36,10,83,158,38,20,96,96,2, +20,89,162,8,44,36,50,9,224,2,0,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,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,4,30,2,5,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,2, +6,2,7,2,8,2,9,2,10,2,11,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, 4099); } diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index b3e1720277..42999c5960 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -92,6 +92,7 @@ static Scheme_Object *variable_top_level_namespace(int, Scheme_Object *[]); static Scheme_Object *variable_phase(int, Scheme_Object *[]); static Scheme_Object *now_transforming(int argc, Scheme_Object *argv[]); static Scheme_Object *local_exp_time_value(int argc, Scheme_Object *argv[]); +static Scheme_Object *local_exp_time_value_one(int argc, Scheme_Object *argv[]); static Scheme_Object *local_exp_time_name(int argc, Scheme_Object *argv[]); static Scheme_Object *local_context(int argc, Scheme_Object *argv[]); static Scheme_Object *local_phase_level(int argc, Scheme_Object *argv[]); @@ -522,6 +523,7 @@ static void make_kernel_env(void) GLOBAL_PRIM_W_ARITY("syntax-transforming?", now_transforming, 0, 0, env); GLOBAL_PRIM_W_ARITY("syntax-local-value", local_exp_time_value, 1, 3, env); + GLOBAL_PRIM_W_ARITY("syntax-local-value/immediate", local_exp_time_value_one, 1, 3, env); GLOBAL_PRIM_W_ARITY("syntax-local-name", local_exp_time_name, 0, 0, env); GLOBAL_PRIM_W_ARITY("syntax-local-context", local_context, 0, 0, env); GLOBAL_PRIM_W_ARITY("syntax-local-phase-level", local_phase_level, 0, 0, env); @@ -1171,6 +1173,22 @@ void scheme_shadow(Scheme_Env *env, Scheme_Object *n, int stxtoo) } else { if (env->shadowed_syntax) scheme_hash_set(env->shadowed_syntax, n, NULL); + + if (rn) { + /* If the syntax binding is a rename transformer, need to install + a mapping. */ + Scheme_Object *v; + v = scheme_lookup_in_table(env->syntax, (const char *)n); + if (v) { + v = SCHEME_PTR_VAL(v); + if (scheme_is_binding_rename_transformer(v)) { + scheme_install_free_id_rename(n, + scheme_rename_transformer_id(v), + rn, + scheme_make_integer(env->phase)); + } + } + } } } @@ -1959,7 +1977,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(&nm, scheme_make_integer(env->phase), NULL, NULL, NULL, NULL, NULL); + mod = scheme_stx_module_name(0, &nm, scheme_make_integer(env->phase), 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)) @@ -2634,7 +2653,8 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, } src_find_id = find_id; - modidx = scheme_stx_module_name(&find_id, scheme_make_integer(phase), NULL, NULL, &mod_defn_phase, NULL, NULL); + modidx = scheme_stx_module_name(0, &find_id, scheme_make_integer(phase), NULL, NULL, &mod_defn_phase, + NULL, NULL, NULL, NULL); /* Used out of context? */ if (SAME_OBJ(modidx, scheme_undefined)) { @@ -2646,9 +2666,10 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, } if (modidx) { - if (!(flags & SCHEME_OUT_OF_CONTEXT_OK)) + if (!(flags & SCHEME_OUT_OF_CONTEXT_OK)) { scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id, "identifier used out of context"); + } if (flags & SCHEME_OUT_OF_CONTEXT_LOCAL) return scheme_make_local(scheme_local_type, 0, 0); return NULL; @@ -2910,7 +2931,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(&id, scheme_make_integer(env->phase), NULL, NULL, NULL, NULL, NULL); + mod = scheme_stx_module_name(0, &id, scheme_make_integer(env->phase), NULL, NULL, NULL, + NULL, NULL, NULL, NULL); if (SAME_OBJ(mod, scheme_undefined)) return 1; } @@ -4149,9 +4171,9 @@ now_transforming(int argc, Scheme_Object *argv[]) } static Scheme_Object * -local_exp_time_value(int argc, Scheme_Object *argv[]) +do_local_exp_time_value(const char *name, int argc, Scheme_Object *argv[], int recur) { - Scheme_Object *v, *sym; + Scheme_Object *v, *sym, *a[2]; Scheme_Env *menv; Scheme_Comp_Env *env; int renamed = 0; @@ -4159,24 +4181,26 @@ local_exp_time_value(int argc, Scheme_Object *argv[]) env = scheme_current_thread->current_local_env; if (!env) scheme_raise_exn(MZEXN_FAIL_CONTRACT, - "syntax-local-value: not currently transforming"); + "%s: not currently transforming", + name); sym = argv[0]; if (!(SCHEME_STXP(sym) && SCHEME_SYMBOLP(SCHEME_STX_VAL(sym)))) - scheme_wrong_type("syntax-local-value", "syntax identifier", 0, argc, argv); + scheme_wrong_type(name, "syntax identifier", 0, argc, argv); if (argc > 1) { - scheme_check_proc_arity2("syntax-local-value", 0, 1, argc, argv, 1); + scheme_check_proc_arity2(name, 0, 1, argc, argv, 1); if ((argc > 2) && SCHEME_TRUEP(argv[2])) { Scheme_Comp_Env *stx_env; if (!SAME_TYPE(scheme_intdef_context_type, SCHEME_TYPE(argv[2]))) - scheme_wrong_type("syntax-local-value", "internal-definition context or #f", 2, argc, argv); + scheme_wrong_type(name, "internal-definition context or #f", 2, argc, argv); stx_env = (Scheme_Comp_Env *)SCHEME_PTR1_VAL(argv[2]); if (!scheme_is_sub_env(stx_env, env)) { - scheme_raise_exn(MZEXN_FAIL_CONTRACT, "syntax-local-value: transforming context does " - "not match given internal-definition context"); + scheme_raise_exn(MZEXN_FAIL_CONTRACT, "%s: transforming context does " + "not match given internal-definition context", + name); } env = stx_env; } @@ -4207,7 +4231,7 @@ local_exp_time_value(int argc, Scheme_Object *argv[]) if ((argc > 1) && SCHEME_TRUEP(argv[1])) return _scheme_tail_apply(argv[1], 0, NULL); else - scheme_arg_mismatch("syntax-local-value", + scheme_arg_mismatch(name, (renamed ? "not defined as syntax (after renaming): " : "not defined as syntax: "), @@ -4215,17 +4239,38 @@ local_exp_time_value(int argc, Scheme_Object *argv[]) } v = SCHEME_PTR_VAL(v); - if (SAME_TYPE(SCHEME_TYPE(v), scheme_id_macro_type)) { - sym = SCHEME_PTR1_VAL(v); + if (scheme_is_rename_transformer(v)) { + sym = scheme_rename_transformer_id(v); sym = scheme_stx_cert(sym, scheme_false, menv, sym, NULL, 1); renamed = 1; menv = NULL; SCHEME_USE_FUEL(1); + if (!recur) { + a[0] = v; + a[1] = sym; + return scheme_values(2, a); + } + } else if (!recur) { + a[0] = v; + a[1] = scheme_false; + return scheme_values(2, a); } else return v; } } +static Scheme_Object * +local_exp_time_value(int argc, Scheme_Object *argv[]) +{ + return do_local_exp_time_value("syntax-local-value", argc, argv, 1); +} + +static Scheme_Object * +local_exp_time_value_one(int argc, Scheme_Object *argv[]) +{ + return do_local_exp_time_value("syntax-local-value/immediate", argc, argv, 0); +} + static Scheme_Object * local_exp_time_name(int argc, Scheme_Object *argv[]) { @@ -4655,10 +4700,10 @@ local_make_delta_introduce(int argc, Scheme_Object *argv[]) introducers = scheme_make_pair(introducer, introducers); v = SCHEME_PTR_VAL(v); - if (SAME_TYPE(SCHEME_TYPE(v), scheme_id_macro_type)) { + if (scheme_is_rename_transformer(v)) { certs = scheme_stx_extract_certs(sym, certs); - sym = SCHEME_PTR1_VAL(v); + sym = scheme_rename_transformer_id(v); sym = scheme_stx_activate_certs(sym); v = SCHEME_PTR2_VAL(v); @@ -5019,7 +5064,7 @@ make_set_transformer(int argc, Scheme_Object *argv[]) static Scheme_Object * set_transformer_p(int argc, Scheme_Object *argv[]) { - return ((SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_set_macro_type)) + return (scheme_is_set_transformer(argv[0]) ? scheme_true : scheme_false); } @@ -5027,10 +5072,10 @@ set_transformer_p(int argc, Scheme_Object *argv[]) static Scheme_Object * set_transformer_proc(int argc, Scheme_Object *argv[]) { - if (!(SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_set_macro_type))) + if (!scheme_is_set_transformer(argv[0])) scheme_wrong_type("set!-transformer-procedure", "set!-transformer", 1, argc, argv); - return SCHEME_PTR_VAL(argv[0]); + return scheme_set_transformer_proc(argv[0]); } static Scheme_Object * @@ -5055,16 +5100,16 @@ make_rename_transformer(int argc, Scheme_Object *argv[]) static Scheme_Object * rename_transformer_target(int argc, Scheme_Object *argv[]) { - if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_id_macro_type)) + if (!scheme_is_rename_transformer(argv[0])) scheme_wrong_type("rename-transformer-target", "rename transformer", 0, argc, argv); - return SCHEME_PTR_VAL(argv[0]); + return scheme_rename_transformer_id(argv[0]); } static Scheme_Object * rename_transformer_p(int argc, Scheme_Object *argv[]) { - return ((SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_id_macro_type)) + return (scheme_is_rename_transformer(argv[0]) ? scheme_true : scheme_false); } diff --git a/src/mzscheme/src/error.c b/src/mzscheme/src/error.c index 0b0ed9010a..e74d9ad92b 100644 --- a/src/mzscheme/src/error.c +++ b/src/mzscheme/src/error.c @@ -660,6 +660,14 @@ call_error(char *buffer, int len, Scheme_Object *exn) "optimizer constant-fold attempt failed%s: %s", scheme_optimize_context_to_string(scheme_current_thread->constant_folding), buffer); + if (SCHEME_STRUCTP(exn) + && scheme_is_struct_instance(exn_table[MZEXN_BREAK].type, exn)) { + /* remember to re-raise exception */ + scheme_current_thread->reading_delayed = exn; + } + scheme_longjmp(scheme_error_buf, 1); + } else if (scheme_current_thread->reading_delayed) { + scheme_current_thread->reading_delayed = exn; scheme_longjmp(scheme_error_buf, 1); } else { mz_jmp_buf savebuf; @@ -1592,7 +1600,8 @@ static void do_wrong_syntax(const char *where, if (scheme_current_thread->current_local_env) phase = scheme_current_thread->current_local_env->genv->phase; else phase = 0; - scheme_stx_module_name(&first, scheme_make_integer(phase), &mod, &nomwho, NULL, NULL, NULL); + scheme_stx_module_name(0, &first, scheme_make_integer(phase), &mod, &nomwho, + NULL, NULL, NULL, NULL, NULL); } } } else { @@ -3253,6 +3262,11 @@ do_raise(Scheme_Object *arg, int need_debug, int eb) scheme_optimize_context_to_string(p->constant_folding), msg); } + if (SCHEME_STRUCTP(arg) + && scheme_is_struct_instance(exn_table[MZEXN_BREAK].type, arg)) { + /* remember to re-raise exception */ + scheme_current_thread->reading_delayed = arg; + } scheme_longjmp (scheme_error_buf, 1); } diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index feada2d58b..9efc9e879a 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -1012,19 +1012,30 @@ static Scheme_Object *try_apply(Scheme_Object *f, Scheme_Object *args, Scheme_Ob folding attempts */ { Scheme_Object * volatile result; + Scheme_Object * volatile exn = NULL; mz_jmp_buf *savebuf, newbuf; + scheme_current_thread->reading_delayed = NULL; scheme_current_thread->constant_folding = (context ? context : scheme_true); savebuf = scheme_current_thread->error_buf; scheme_current_thread->error_buf = &newbuf; - if (scheme_setjmp(newbuf)) + if (scheme_setjmp(newbuf)) { result = NULL; - else + exn = scheme_current_thread->reading_delayed; + } else result = _scheme_apply_to_list(f, args); scheme_current_thread->error_buf = savebuf; scheme_current_thread->constant_folding = NULL; + scheme_current_thread->reading_delayed = NULL; + + if (scheme_current_thread->cjs.is_kill) { + scheme_longjmp(*scheme_current_thread->error_buf, 1); + } + + if (exn) + scheme_raise(exn); return result; } @@ -2891,6 +2902,12 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info) } else t = scheme_optimize_expr(t, info); + /* For test position, convert (if #t #f) to */ + if (SAME_TYPE(SCHEME_TYPE(t), scheme_branch_type) + && SAME_OBJ(((Scheme_Branch_Rec *)t)->tbranch, scheme_true) + && SAME_OBJ(((Scheme_Branch_Rec *)t)->fbranch, scheme_false)) + t = ((Scheme_Branch_Rec *)t)->test; + if (SCHEME_TYPE(t) > _scheme_compiled_values_types_) { if (SCHEME_FALSEP(t)) return scheme_optimize_expr(fb, info); @@ -5193,9 +5210,10 @@ Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first, SCHEME_EXPAND_OBSERVE_EXIT_CHECK(rec[drec].observer, first); return first; } else if (SAME_TYPE(SCHEME_TYPE(val), scheme_macro_type)) { - if (SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(val)), scheme_id_macro_type)) { + if (scheme_is_rename_transformer(SCHEME_PTR_VAL(val))) { /* It's a rename. Look up the target name and try again. */ - name = scheme_stx_cert(SCHEME_PTR_VAL(SCHEME_PTR_VAL(val)), scheme_false, menv, name, NULL, 1); + name = scheme_stx_cert(scheme_rename_transformer_id(SCHEME_PTR_VAL(val)), + scheme_false, menv, name, NULL, 1); menv = NULL; SCHEME_USE_FUEL(1); } else { @@ -5236,7 +5254,7 @@ compile_expand_macro_app(Scheme_Object *name, Scheme_Env *menv, Scheme_Object *m xformer = (Scheme_Object *)SCHEME_PTR_VAL(macro); - if (SAME_TYPE(SCHEME_TYPE(xformer), scheme_set_macro_type)) { + if (scheme_is_set_transformer(xformer)) { /* scheme_apply_macro unwraps it */ } else { if (!scheme_check_proc_arity(NULL, 1, 0, -1, &xformer)) { @@ -5391,10 +5409,10 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, SCHEME_EXPAND_OBSERVE_RESOLVE(rec[drec].observer,find_name); if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) - && SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_id_macro_type)) { + && scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) { /* It's a rename. Look up the target name and try again. */ Scheme_Object *new_name; - new_name = SCHEME_PTR_VAL(SCHEME_PTR_VAL(var)); + new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var)); if (!rec[drec].comp) { new_name = scheme_stx_track(new_name, find_name, find_name); } @@ -5497,10 +5515,10 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, SCHEME_EXPAND_OBSERVE_RESOLVE(rec[drec].observer, find_name); if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) - && SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_id_macro_type)) { + && scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) { /* It's a rename. Look up the target name and try again. */ Scheme_Object *new_name; - new_name = SCHEME_PTR_VAL(SCHEME_PTR_VAL(var)); + new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var)); if (!rec[drec].comp) { new_name = scheme_stx_track(new_name, find_name, find_name); } @@ -5584,10 +5602,10 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, SCHEME_EXPAND_OBSERVE_RESOLVE(rec[drec].observer, find_name); if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) - && SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_id_macro_type)) { + && scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) { /* It's a rename. Look up the target name and try again. */ Scheme_Object *new_name; - new_name = SCHEME_PTR_VAL(SCHEME_PTR_VAL(var)); + new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var)); if (!rec[drec].comp) { new_name = scheme_stx_track(new_name, find_name, find_name); } @@ -6070,7 +6088,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(&symbol, scheme_make_integer(env->genv->phase), NULL, NULL, NULL, NULL, NULL); + modidx = scheme_stx_module_name(0, &symbol, scheme_make_integer(env->genv->phase), NULL, NULL, NULL, + NULL, NULL, NULL, NULL); if (modidx) { /* If it's an access path, resolve it: */ if (env->genv->module @@ -6535,7 +6554,7 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, names, expr, new_env->genv->exp_env, new_env->insp, rec, drec, new_env, new_env, - &pos); + &pos, rib); } /* Remember extended environment */ @@ -7082,6 +7101,19 @@ static void make_tail_buffer_safe() p->tail_buffer = tb; } +static Scheme_Object **evacuate_runstack(int num_rands, Scheme_Object **rands, Scheme_Object **runstack) +{ + if (rands == runstack) { + /* See [TC-SFS] in "schnapp.inc" */ + Scheme_Thread *p = scheme_current_thread; + (void)scheme_tail_apply(scheme_void, num_rands, rands); + rands = p->ku.apply.tail_rands; + p->ku.apply.tail_rands = NULL; + return rands; + } else + return rands; +} + static Scheme_Dynamic_Wind *intersect_dw(Scheme_Dynamic_Wind *a, Scheme_Dynamic_Wind *b, Scheme_Object *prompt_tag, int b_has_tag, int *_common_depth) { @@ -7530,6 +7562,7 @@ void scheme_escape_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Obj Scheme_Object * scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands, int get_value) + /* If rands == MZ_RUNSTACK on entry, rands elements can be modified. */ { Scheme_Type type; Scheme_Object *v; @@ -7601,6 +7634,8 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands, if ((RUNSTACK - RUNSTACK_START) < SCHEME_TAIL_COPY_THRESHOLD) { /* It's possible that a sequence of primitive _scheme_tail_apply() calls will exhaust the Scheme stack. Watch out for that. */ + rands = evacuate_runstack(num_rands, rands, RUNSTACK); + p->ku.k.p1 = (void *)obj; p->ku.k.i1 = num_rands; p->ku.k.p2 = (void *)rands; @@ -7673,6 +7708,8 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands, data = SCHEME_COMPILED_CLOS_CODE(obj); if ((RUNSTACK - RUNSTACK_START) < data->max_let_depth) { + rands = evacuate_runstack(num_rands, rands, RUNSTACK); + if (rands == p->tail_buffer) { UPDATE_THREAD_RSPTR_FOR_GC(); make_tail_buffer_safe(); @@ -7917,6 +7954,14 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands, v = data->code(obj, num_rands, rands); + if (v == SCHEME_TAIL_CALL_WAITING) { + /* [TC-SFS]; see schnapp.inc */ + if (rands == old_runstack) { + int i; + for (i = 0; i < num_rands; i++) { rands[i] = NULL; } + } + } + DEBUG_CHECK_TYPE(v); #endif } else if (type == scheme_cont_type) { @@ -7996,6 +8041,14 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands, v = prim->prim_val(prim->data, num_rands, rands); + if (v == SCHEME_TAIL_CALL_WAITING) { + /* [TC-SFS]; see schnapp.inc */ + if (rands == old_runstack) { + int i; + for (i = 0; i < num_rands; i++) { rands[i] = NULL; } + } + } + DEBUG_CHECK_TYPE(v); } else { UPDATE_THREAD_RSPTR_FOR_ERROR(); @@ -9800,7 +9853,7 @@ local_eval(int argc, Scheme_Object **argv) scheme_bind_syntaxes("local syntax definition", names, expr, stx_env->genv->exp_env, stx_env->insp, &rec, 0, stx_env, stx_env, - &pos); + &pos, rib); } /* Extend shared rib with renamings */ diff --git a/src/mzscheme/src/fun.c b/src/mzscheme/src/fun.c index df919cb3a5..d1f95d53bc 100644 --- a/src/mzscheme/src/fun.c +++ b/src/mzscheme/src/fun.c @@ -447,7 +447,7 @@ scheme_init_fun (Scheme_Env *env) scheme_add_global_constant("current-process-milliseconds", scheme_make_prim_w_arity(current_process_milliseconds, "current-process-milliseconds", - 0, 0), + 0, 1), env); scheme_add_global_constant("current-gc-milliseconds", scheme_make_prim_w_arity(current_gc_milliseconds, @@ -1827,7 +1827,8 @@ typedef Scheme_Object *(*Overflow_K_Proc)(void); THREAD_LOCAL Scheme_Overflow_Jmp *scheme_overflow_jmp; THREAD_LOCAL void *scheme_overflow_stack_start; -/* private, but declared public to avoid inlining: */ +MZ_DO_NOT_INLINE(void scheme_really_create_overflow(void *stack_base)); + void scheme_really_create_overflow(void *stack_base) { Scheme_Overflow_Jmp *jmp; @@ -2603,10 +2604,10 @@ scheme_apply_macro(Scheme_Object *name, Scheme_Env *menv, Scheme_Object *certs; certs = rec[drec].certs; - if (SAME_TYPE(SCHEME_TYPE(rator), scheme_id_macro_type)) { + if (scheme_is_rename_transformer(rator)) { Scheme_Object *mark; - rator = SCHEME_PTR1_VAL(rator); + rator = scheme_rename_transformer_id(rator); /* rator is now an identifier */ /* and it's introduced by this expression: */ @@ -2639,8 +2640,8 @@ scheme_apply_macro(Scheme_Object *name, Scheme_Env *menv, certs = scheme_stx_extract_certs(code, certs); - if (SAME_TYPE(SCHEME_TYPE(rator), scheme_set_macro_type)) - rator = SCHEME_PTR_VAL(rator); + if (scheme_is_set_transformer(rator)) + rator = scheme_set_transformer_proc(rator); mark = scheme_new_mark(); code = scheme_add_remove_mark(code, mark); @@ -5747,7 +5748,9 @@ void scheme_drop_prompt_meta_continuations(Scheme_Object *prompt_tag) scheme_current_thread->meta_continuation = mc; } -/* private, but declared public to avoid inlining: */ +MZ_DO_NOT_INLINE(Scheme_Object *scheme_finish_apply_for_prompt(Scheme_Prompt *prompt, Scheme_Object *_prompt_tag, + Scheme_Object *proc, int argc, Scheme_Object **argv)); + Scheme_Object *scheme_finish_apply_for_prompt(Scheme_Prompt *prompt, Scheme_Object *_prompt_tag, Scheme_Object *proc, int argc, Scheme_Object **argv) { @@ -5887,7 +5890,9 @@ Scheme_Object *scheme_finish_apply_for_prompt(Scheme_Prompt *prompt, Scheme_Obje } } -/* private, but declared public to avoid inlining: */ +MZ_DO_NOT_INLINE(Scheme_Object *scheme_apply_for_prompt(Scheme_Prompt *prompt, Scheme_Object *prompt_tag, + Scheme_Object *proc, int argc, Scheme_Object **argv)); + Scheme_Object *scheme_apply_for_prompt(Scheme_Prompt *prompt, Scheme_Object *prompt_tag, Scheme_Object *proc, int argc, Scheme_Object **argv) { @@ -7986,6 +7991,19 @@ long scheme_get_process_milliseconds(void) #endif } +long scheme_get_thread_milliseconds(Scheme_Object *thrd) +{ + Scheme_Thread *t = thrd ? (Scheme_Thread *)thrd : scheme_current_thread; + + if (t == scheme_current_thread) { + long cpm; + cpm = scheme_get_process_milliseconds(); + return t->accum_process_msec + (cpm - t->current_start_process_msec); + } else { + return t->accum_process_msec; + } +} + #ifdef MZ_XFORM END_XFORM_SKIP; #endif @@ -8272,7 +8290,14 @@ static Scheme_Object *current_inexact_milliseconds(int argc, Scheme_Object **arg static Scheme_Object *current_process_milliseconds(int argc, Scheme_Object **argv) { - return scheme_make_integer(scheme_get_process_milliseconds()); + if (!argc || SCHEME_FALSEP(argv[0])) + return scheme_make_integer(scheme_get_process_milliseconds()); + else { + if (SCHEME_THREADP(argv[0])) + return scheme_make_integer(scheme_get_thread_milliseconds(argv[0])); + scheme_wrong_type("current-process-milliseconds", "thread", 0, argc, argv); + return NULL; + } } static Scheme_Object *current_gc_milliseconds(int argc, Scheme_Object **argv) diff --git a/src/mzscheme/src/gmp/gmp.c b/src/mzscheme/src/gmp/gmp.c index f754b14157..13a61a2fd1 100644 --- a/src/mzscheme/src/gmp/gmp.c +++ b/src/mzscheme/src/gmp/gmp.c @@ -21,13 +21,11 @@ MA 02111-1307, USA. */ #define _FORCE_INLINES #define _EXTERN_INLINE /* empty */ -/* We use malloc for now; this will have to change. */ -/* The allocation function should not create collectable - memory, though it can safely GC when allocating. */ -extern void *malloc(unsigned long); -extern void free(void *); -#define MALLOC malloc -#define FREE(p, s) free(p) +extern void *scheme_malloc_gmp(unsigned long, void **mem_pool); +extern void scheme_free_gmp(void *, void **mem_pool); +static void *mem_pool = 0; +#define MALLOC(amt) scheme_malloc_gmp(amt, &mem_pool) +#define FREE(p, s) scheme_free_gmp(p, &mem_pool) #include "../../sconfig.h" #include "mzconfig.h" @@ -5796,18 +5794,21 @@ void scheme_gmp_tls_init(long *s) ((tmp_marker *)(s + 3))->alloc_point = &xxx; } -void scheme_gmp_tls_load(long *s) +void *scheme_gmp_tls_load(long *s) { s[0] = (long)current_total_allocation; s[1] = (long)max_total_allocation; s[2] = (long)current; + return mem_pool; } -void scheme_gmp_tls_unload(long *s) +void scheme_gmp_tls_unload(long *s, void *data) { current_total_allocation = (unsigned long)s[0]; max_total_allocation = (unsigned long)s[1]; current = (tmp_stack *)s[2]; + s[0] = 0; + mem_pool = data; } void scheme_gmp_tls_snapshot(long *s, long *save) @@ -5817,14 +5818,16 @@ void scheme_gmp_tls_snapshot(long *s, long *save) __gmp_tmp_mark((tmp_marker *)(s + 3)); } -void scheme_gmp_tls_restore_snapshot(long *s, long *save, int do_free) +void scheme_gmp_tls_restore_snapshot(long *s, void *data, long *save, int do_free) { long other[6]; + void *other_data; if (do_free == 2) { - scheme_gmp_tls_load(other); - scheme_gmp_tls_unload(s); - } + other_data = scheme_gmp_tls_load(other); + scheme_gmp_tls_unload(s, data); + } else + other_data = NULL; if (do_free) __gmp_tmp_free((tmp_marker *)(s + 3)); @@ -5832,11 +5835,12 @@ void scheme_gmp_tls_restore_snapshot(long *s, long *save, int do_free) if (save) { s[3] = save[0]; s[4] = save[1]; + } if (do_free == 2) { - scheme_gmp_tls_load(s); - scheme_gmp_tls_unload(other); + data = scheme_gmp_tls_load(s); + scheme_gmp_tls_unload(other, other_data); } } diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index 05fcfb6ea3..235c69cbb7 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -175,6 +175,7 @@ typedef struct { void *status_at_ptr; int reg_status; void *patch_depth; + int rs_virtual_offset; } mz_jit_state; #define mz_RECORD_STATUS(s) (jitter->status_at_ptr = _jit.x.pc, jitter->reg_status = (s)) @@ -631,6 +632,15 @@ static Scheme_Object *tail_call_with_values_from_multiple_result(Scheme_Object * return scheme_tail_apply(f, num_rands, p->ku.multiple.array); } +static Scheme_Object *clear_runstack(long amt, Scheme_Object *sv) +{ + int i; + for (i = 0; i < amt; i++) { + MZ_RUNSTACK[i] = NULL; + } + return sv; +} + /*========================================================================*/ /* code-gen utils */ /*========================================================================*/ @@ -681,6 +691,40 @@ static void *top4; # define VALIDATE_RESULT(reg) /* empty */ #endif +/* The mz_rs_... family of operations operate on a virtual + JIT_RUNSTACK register to perform a kind of peephole optimization. + The virtual register can be de-sync'd from the actual register, so + that multiple adjustments to the register can be collapsed; this + mostly improves code size, rather than speed. Functions that cause + the register to be de-sync'd are marked as such. Functions that can + accomodate a de-sync'd register on entry are marked as such. All + other fuctions can assume a sync'd regsiter and ensure a sync'd + register. Note that branches and calls normally require a sync'd + register. */ + +#if 1 +# define mz_rs_dec(n) (jitter->rs_virtual_offset -= (n)) +# define mz_rs_inc(n) (jitter->rs_virtual_offset += (n)) +# define mz_rs_ldxi(reg, n) jit_ldxi_p(reg, JIT_RUNSTACK, WORDS_TO_BYTES(((n) + jitter->rs_virtual_offset))) +# define mz_rs_ldr(reg) mz_rs_ldxi(reg, 0) +# define mz_rs_stxi(n, reg) jit_stxi_p(WORDS_TO_BYTES(((n) + jitter->rs_virtual_offset)), JIT_RUNSTACK, reg) +# define mz_rs_str(reg) mz_rs_stxi(0, reg) +# define mz_rs_sync() (jitter->rs_virtual_offset \ + ? (jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(jitter->rs_virtual_offset)), \ + jitter->rs_virtual_offset = 0) \ + : 0) +# define mz_rs_sync_0() (jitter->rs_virtual_offset = 0) +#else +# define mz_rs_dec(n) jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(n)) +# define mz_rs_inc(n) jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(n)) +# define mz_rs_ldr(reg) jit_ldr_p(reg, JIT_RUNSTACK) +# define mz_rs_ldxi(reg, n) jit_ldxi_p(reg, JIT_RUNSTACK, WORDS_TO_BYTES(n)) +# define mz_rs_str(reg) jit_str_p(JIT_RUNSTACK, reg) +# define mz_rs_stxi(n, reg) jit_stxi_p(WORDS_TO_BYTES(n), JIT_RUNSTACK, reg) +# define mz_rs_sync() /* empty */ +# define mz_rs_sync_0() /* empty */ +#endif + static void new_mapping(mz_jit_state *jitter) { jitter->num_mappings++; @@ -695,6 +739,7 @@ static void new_mapping(mz_jit_state *jitter) } static void mz_pushr_p_it(mz_jit_state *jitter, int reg) +/* de-sync's rs */ { int v; @@ -710,14 +755,15 @@ static void mz_pushr_p_it(mz_jit_state *jitter, int reg) v++; jitter->mappings[jitter->num_mappings] = ((v << 1) | 0x1); - jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); + mz_rs_dec(1); CHECK_RUNSTACK_OVERFLOW_NOCL(); - jit_str_p(JIT_RUNSTACK, reg); + mz_rs_str(reg); jitter->need_set_rs = 1; } static void mz_popr_p_it(mz_jit_state *jitter, int reg) +/* de-sync's rs */ { int v; @@ -731,8 +777,8 @@ static void mz_popr_p_it(mz_jit_state *jitter, int reg) else jitter->mappings[jitter->num_mappings] = ((v << 1) | 0x1); - jit_ldr_p(reg, JIT_RUNSTACK); - jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); + mz_rs_ldr(reg); + mz_rs_inc(1); jitter->need_set_rs = 1; } @@ -910,18 +956,21 @@ static int mz_is_closure(mz_jit_state *jitter, int i, int arity, int *_flags) } static int stack_safety(mz_jit_state *jitter, int cnt, int offset) +/* de-sync'd rs ok */ { /* To preserve space safety, we must initialize any stack room that we make, so that whatever happens to be there isn't - traversed in case of a GC. */ + traversed in case of a GC. the value of JIT_RUNSTACK is + handy to use as a "clear" value. */ int i; for (i = 0; i < cnt; i++) { - jit_stxi_p(WORDS_TO_BYTES(i+offset), JIT_RUNSTACK, JIT_RUNSTACK); + mz_rs_stxi(i+offset, JIT_RUNSTACK); CHECK_LIMIT(); } return 1; } +/* de-sync's rs: */ #define mz_pushr_p(x) mz_pushr_p_it(jitter, x) #define mz_popr_p(x) mz_popr_p_it(jitter, x) @@ -1981,7 +2030,7 @@ static int generate_retry_call(mz_jit_state *jitter, int num_rands, int multi_ok jit_subr_l(JIT_RUNSTACK, JIT_RUNSTACK, JIT_R2); CHECK_RUNSTACK_OVERFLOW(); - /* Copy argument to runstack, then jump to reftop. */ + /* Copy arguments to runstack, then jump to reftop. */ jit_ldxi_l(JIT_R2, JIT_R1, &((Scheme_Thread *)0x0)->ku.apply.tail_num_rands); jit_ldxi_l(JIT_V1, JIT_R1, &((Scheme_Thread *)0x0)->ku.apply.tail_rands); jit_lshi_l(JIT_R2, JIT_R2, JIT_LOG_WORD_SIZE); @@ -2010,6 +2059,31 @@ static int generate_retry_call(mz_jit_state *jitter, int num_rands, int multi_ok return 1; } +static int generate_clear_previous_args(mz_jit_state *jitter, int num_rands) +{ + if (num_rands >= 0) { + int i; + for (i = 0; i < num_rands; i++) { + jit_stxi_p(WORDS_TO_BYTES(i), JIT_RUNSTACK, JIT_RUNSTACK); + CHECK_LIMIT(); + } + } else { + /* covered by generate_clear_slow_previous_args */ + } + return 1; +} + +static int generate_clear_slow_previous_args(mz_jit_state *jitter) +{ + CHECK_LIMIT(); + mz_prepare(2); + jit_pusharg_p(JIT_R0); + jit_pusharg_l(JIT_V1); + mz_finish(clear_runstack); + jit_retval(JIT_R0); + return 1; +} + static int generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direct_native, int need_set_rs, int multi_ok, int nontail_self, int pop_and_jump) { @@ -2152,6 +2226,8 @@ static int generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direc __START_SHORT_JUMPS__(1); } ref6 = jit_bnei_p(jit_forward(), JIT_R0, SCHEME_TAIL_CALL_WAITING); + generate_clear_previous_args(jitter, num_rands); + CHECK_LIMIT(); if (pop_and_jump) { /* Expects argc in V1 if num_rands < 0: */ generate_retry_call(jitter, num_rands, multi_ok, reftop); @@ -2160,6 +2236,10 @@ static int generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direc if (need_set_rs) { JIT_UPDATE_THREAD_RSPTR(); } + if (num_rands < 0) { + generate_clear_slow_previous_args(jitter); + CHECK_LIMIT(); + } mz_prepare(1); jit_pusharg_p(JIT_R0); if (multi_ok) { @@ -2203,11 +2283,17 @@ static int generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direc __START_SHORT_JUMPS__(1); } ref10 = jit_bnei_p(jit_forward(), JIT_R0, SCHEME_TAIL_CALL_WAITING); + generate_clear_previous_args(jitter, num_rands); + CHECK_LIMIT(); if (pop_and_jump) { /* Expects argc in V1 if num_rands < 0: */ generate_retry_call(jitter, num_rands, multi_ok, reftop); } CHECK_LIMIT(); + if (num_rands < 0) { + generate_clear_slow_previous_args(jitter); + CHECK_LIMIT(); + } mz_prepare(1); jit_pusharg_p(JIT_R0); if (multi_ok) { @@ -2334,6 +2420,7 @@ static int generate_self_tail_call(Scheme_Object *rator, mz_jit_state *jitter, i jit_stxi_p(WORDS_TO_BYTES(num_rands - 1), JIT_RUNSTACK, JIT_R0); generate(rator, jitter, 0, 0, JIT_V1); CHECK_LIMIT(); + mz_rs_sync(); (void)jit_jmpi(slow_code); @@ -2514,6 +2601,7 @@ 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 */ { int i, offset, need_safety = 0; int direct_prim = 0, need_non_tail = 0, direct_native = 0, direct_self = 0, nontail_self = 0; @@ -2650,7 +2738,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ if (num_rands) { if (!direct_prim || (num_rands > 1)) { - jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(num_rands)); + mz_rs_dec(num_rands); need_safety = num_rands; CHECK_RUNSTACK_OVERFLOW(); mz_runstack_pushed(jitter, num_rands); @@ -2680,7 +2768,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ need_safety = 0; } - generate_non_tail(rator, jitter, 0, !need_non_tail); + generate_non_tail(rator, jitter, 0, !need_non_tail); /* sync'd after args below */ CHECK_LIMIT(); if (num_rands) { @@ -2696,7 +2784,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ jit_movr_p(JIT_V1, JIT_R0); proc_already_in_place = 1; } else { - jit_stxi_p(WORDS_TO_BYTES(num_rands - 1 + offset), JIT_RUNSTACK, JIT_R0); + mz_rs_stxi(num_rands - 1 + offset, JIT_R0); if (need_safety) need_safety--; } @@ -2704,6 +2792,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ jit_movr_p(JIT_V1, JIT_R0); } } + /* not sync'd...*/ for (i = 0; i < num_rands; i++) { PAUSE_JIT_DATA(); @@ -2715,18 +2804,19 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ CHECK_LIMIT(); need_safety = 0; } - generate_non_tail(arg, jitter, 0, !need_non_tail); + generate_non_tail(arg, jitter, 0, !need_non_tail); /* sync'd below */ RESUME_JIT_DATA(); CHECK_LIMIT(); if ((i == num_rands - 1) && !direct_prim && !reorder_ok && !direct_self && !proc_already_in_place) { /* Move rator back to register: */ - jit_ldxi_p(JIT_V1, JIT_RUNSTACK, WORDS_TO_BYTES(i + offset)); + mz_rs_ldxi(JIT_V1, i + offset); } if ((!direct_prim || (num_rands > 1)) && (!direct_self || !is_tail || no_call || (i + 1 < num_rands))) { - jit_stxi_p(WORDS_TO_BYTES(i + offset), JIT_RUNSTACK, JIT_R0); + mz_rs_stxi(i + offset, JIT_R0); } } + /* not sync'd... */ if (need_non_tail) { /* Uses JIT_R2: */ @@ -2740,6 +2830,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ if (num_rands == 1) { mz_runstack_unskipped(jitter, 1); } else { + mz_rs_sync(); JIT_UPDATE_THREAD_RSPTR_IF_NEEDED(); } LOG_IT(("direct: %s\n", ((Scheme_Primitive_Proc *)rator)->name)); @@ -2747,11 +2838,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); + if (!no_call) { + generate(rator, jitter, 0, 0, JIT_V1); /* sync'd below */ + } CHECK_LIMIT(); } + mz_rs_sync(); + END_JIT_DATA(20); if (direct_prim || direct_native || direct_self || nontail_self) @@ -3145,6 +3239,7 @@ static int generate_double_arith(mz_jit_state *jitter, int arith, int cmp, int r static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Object *rand, Scheme_Object *rand2, int orig_args, int arith, int cmp, int v, jit_insn **for_branch, int branch_short) +/* needs de-sync */ /* Either arith is non-zero or it's a cmp; the value of each determines the operation: arith = 1 -> + or add1 (if !rand2) arith = -1 -> - or sub1 @@ -3233,28 +3328,31 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj if (rand2 && !simple_rand && !simple_rand2) { mz_runstack_skipped(jitter, 1); - generate_non_tail(rand, jitter, 0, 1); + generate_non_tail(rand, jitter, 0, 1); /* sync'd later */ CHECK_LIMIT(); mz_runstack_unskipped(jitter, 1); - jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); + mz_rs_dec(1); CHECK_RUNSTACK_OVERFLOW(); mz_runstack_pushed(jitter, 1); - jit_str_p(JIT_RUNSTACK, JIT_R0); + mz_rs_str(JIT_R0); } + /* not sync'd... */ if (simple_rand2) { if (SAME_TYPE(SCHEME_TYPE(rand), scheme_local_type)) - generate(rand, jitter, 0, 0, JIT_R1); + generate(rand, jitter, 0, 0, JIT_R1); /* sync'd below */ else { - generate_non_tail(rand, jitter, 0, 1); + generate_non_tail(rand, jitter, 0, 1); /* sync'd below */ + CHECK_LIMIT(); jit_movr_p(JIT_R1, JIT_R0); } CHECK_LIMIT(); - generate(rand2, jitter, 0, 0, JIT_R0); + generate(rand2, jitter, 0, 0, JIT_R0); /* sync'd below */ } else { - generate_non_tail(rand2 ? rand2 : rand, jitter, 0, 1); + generate_non_tail(rand2 ? rand2 : rand, jitter, 0, 1); /* sync'd below */ } CHECK_LIMIT(); + /* sync'd in three branches below */ if (arith == -2) { if (rand2 || (v != 1) || reversed) @@ -3272,13 +3370,15 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj } else { if (simple_rand) { pos = mz_remap(SCHEME_LOCAL_POS(rand)); - jit_ldxi_p(JIT_R1, JIT_RUNSTACK, WORDS_TO_BYTES(pos)); + mz_rs_ldxi(JIT_R1, pos); } /* check both fixnum bits at once by ANDing into R2: */ jit_andr_ul(JIT_R2, JIT_R0, JIT_R1); va = JIT_R2; } + mz_rs_sync(); + __START_TINY_JUMPS__(1); ref2 = jit_bmsi_ul(jit_forward(), va, 0x1); __END_TINY_JUMPS__(1); @@ -3306,10 +3406,12 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj CHECK_LIMIT(); } else if (rand2) { /* Move rand result back into R1 */ - jit_ldr_p(JIT_R1, JIT_RUNSTACK); - jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); + mz_rs_ldr(JIT_R1); + mz_rs_inc(1); mz_runstack_popped(jitter, 1); + mz_rs_sync(); + /* check both fixnum bits at once by ANDing into R2: */ jit_andr_ul(JIT_R2, JIT_R0, JIT_R1); __START_TINY_JUMPS__(1); @@ -3340,6 +3442,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj } CHECK_LIMIT(); } else { + mz_rs_sync(); /* Only one argument: */ __START_TINY_JUMPS__(1); ref2 = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1); @@ -3685,6 +3788,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj static int generate_inlined_constant_test(mz_jit_state *jitter, Scheme_App2_Rec *app, Scheme_Object *cnst, Scheme_Object *cnst2, jit_insn **for_branch, int branch_short) +/* de-sync'd ok */ { GC_CAN_IGNORE jit_insn *ref, *ref2; @@ -3697,6 +3801,8 @@ static int generate_inlined_constant_test(mz_jit_state *jitter, Scheme_App2_Rec mz_runstack_unskipped(jitter, 1); + mz_rs_sync(); + __START_SHORT_JUMPS__(branch_short); if (cnst2) { @@ -3740,6 +3846,8 @@ static int generate_inlined_type_test(mz_jit_state *jitter, Scheme_App2_Rec *app mz_runstack_unskipped(jitter, 1); + mz_rs_sync(); + __START_SHORT_JUMPS__(branch_short); ref = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1); @@ -3785,35 +3893,38 @@ 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, jit_insn **for_branch, int branch_short) +/* 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); + 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); + generate(rand, jitter, 0, 0, JIT_R0); /* sync'd below */ mz_runstack_unskipped(jitter, 1); } else { mz_runstack_unskipped(jitter, 1); - jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); + mz_rs_dec(1); CHECK_RUNSTACK_OVERFLOW(); mz_runstack_pushed(jitter, 1); - jit_str_p(JIT_RUNSTACK, JIT_R0); + mz_rs_str(JIT_R0); CHECK_LIMIT(); - generate_non_tail(rand, jitter, 0, 1); + generate_non_tail(rand, jitter, 0, 1); /* sync'd below */ CHECK_LIMIT(); - jit_ldr_p(JIT_R1, JIT_RUNSTACK); - jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); + mz_rs_ldr(JIT_R1); + mz_rs_inc(1); mz_runstack_popped(jitter, 1); } + mz_rs_sync(); + /* R1 is [potential] predicate/getter, R0 is value */ if (for_branch) { @@ -3834,6 +3945,7 @@ static int generate_vector_alloc(mz_jit_state *jitter, Scheme_Object *rator, static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, int is_tail, int multi_ok, jit_insn **for_branch, int branch_short) +/* de-sync's, unless branch */ { Scheme_Object *rator = app->rator; @@ -3938,6 +4050,8 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in mz_runstack_unskipped(jitter, 1); + mz_rs_sync(); + /* Jump ahead if it's a fixnum: */ __START_TINY_JUMPS__(1); ref = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1); @@ -4009,6 +4123,8 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in mz_runstack_unskipped(jitter, 1); + mz_rs_sync(); + __START_TINY_JUMPS__(1); if (steps > 1) { @@ -4072,6 +4188,8 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in mz_runstack_unskipped(jitter, 1); + mz_rs_sync(); + __START_TINY_JUMPS__(1); ref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1); @@ -4108,6 +4226,8 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in mz_runstack_unskipped(jitter, 1); + mz_rs_sync(); + __START_TINY_JUMPS__(1); ref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1); __END_TINY_JUMPS__(1); @@ -4138,6 +4258,8 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in mz_runstack_unskipped(jitter, 1); + mz_rs_sync(); + __START_TINY_JUMPS__(1); ref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1); __END_TINY_JUMPS__(1); @@ -4164,6 +4286,8 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in mz_runstack_unskipped(jitter, 1); + mz_rs_sync(); + (void)jit_calli(syntax_e_code); return 1; @@ -4196,6 +4320,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in mz_runstack_skipped(jitter, 1); generate_non_tail(app->rand, jitter, 0, 1); CHECK_LIMIT(); + mz_rs_sync(); mz_runstack_unskipped(jitter, 1); (void)jit_movi_p(JIT_R1, &scheme_null); return generate_cons_alloc(jitter, 0, 0); @@ -4204,7 +4329,8 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in generate_non_tail(app->rand, jitter, 0, 1); CHECK_LIMIT(); mz_runstack_unskipped(jitter, 1); - + mz_rs_sync(); + #ifdef CAN_INLINE_ALLOC /* Inlined alloc */ (void)jit_movi_p(JIT_R1, NULL); /* needed because R1 is marked during a GC */ @@ -4237,7 +4363,8 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in } static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_state *jitter, int order_matters) -/* Results go into R0 and R1. If !order_matters, and if only the +/* 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. */ { int simple1, simple2, direction = 1; @@ -4249,11 +4376,11 @@ static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_ if (simple2) { mz_runstack_skipped(jitter, 2); - generate_non_tail(rand1, jitter, 0, 1); + generate_non_tail(rand1, jitter, 0, 1); /* no sync... */ CHECK_LIMIT(); jit_movr_p(JIT_R1, JIT_R0); - generate(rand2, jitter, 0, 0, JIT_R0); + generate(rand2, jitter, 0, 0, JIT_R0); /* no sync... */ CHECK_LIMIT(); if (order_matters) { @@ -4267,39 +4394,39 @@ static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_ mz_runstack_unskipped(jitter, 2); } else { mz_runstack_skipped(jitter, 2); - generate_non_tail(rand1, jitter, 0, 1); + generate_non_tail(rand1, jitter, 0, 1); /* no sync... */ CHECK_LIMIT(); mz_runstack_unskipped(jitter, 2); - jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); + mz_rs_dec(1); CHECK_RUNSTACK_OVERFLOW(); mz_runstack_pushed(jitter, 1); - jit_str_p(JIT_RUNSTACK, JIT_R0); + mz_rs_str(JIT_R0); mz_runstack_skipped(jitter, 1); - generate_non_tail(rand2, jitter, 0, 1); + generate_non_tail(rand2, jitter, 0, 1); /* no sync... */ CHECK_LIMIT(); jit_movr_p(JIT_R1, JIT_R0); - jit_ldr_p(JIT_R0, JIT_RUNSTACK); + mz_rs_ldr(JIT_R0); mz_runstack_unskipped(jitter, 1); - jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); + mz_rs_inc(1); mz_runstack_popped(jitter, 1); } } else { mz_runstack_skipped(jitter, 2); if (simple2) { - generate(rand2, jitter, 0, 0, JIT_R1); + generate(rand2, jitter, 0, 0, JIT_R1); /* no sync... */ CHECK_LIMIT(); } else { - generate_non_tail(rand2, jitter, 0, 1); + generate_non_tail(rand2, jitter, 0, 1); /* no sync... */ CHECK_LIMIT(); jit_movr_p(JIT_R1, JIT_R0); } - generate(rand1, jitter, 0, 0, JIT_R0); + generate(rand1, jitter, 0, 0, JIT_R0); /* no sync... */ CHECK_LIMIT(); mz_runstack_unskipped(jitter, 2); @@ -4310,6 +4437,7 @@ static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_ static int generate_binary_char(mz_jit_state *jitter, Scheme_App3_Rec *app, jit_insn **for_branch, int branch_short) +/* de-sync'd ok */ { Scheme_Object *r1, *r2, *rator = app->rator; GC_CAN_IGNORE jit_insn *reffail = NULL, *ref; @@ -4322,6 +4450,8 @@ static int generate_binary_char(mz_jit_state *jitter, Scheme_App3_Rec *app, direction = generate_two_args(r1, r2, jitter, 1); CHECK_LIMIT(); + mz_rs_sync(); + __START_SHORT_JUMPS__(branch_short); if (!SCHEME_CHARP(r1)) { @@ -4437,6 +4567,7 @@ static int generate_vector_op(mz_jit_state *jitter, int set) static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, int is_tail, int multi_ok, jit_insn **for_branch, int branch_short) +/* de-sync's; for branch, sync'd before */ { Scheme_Object *rator = app->rator; @@ -4470,6 +4601,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i generate_non_tail(a2, jitter, 0, 1); CHECK_LIMIT(); + mz_rs_sync(); mz_runstack_unskipped(jitter, 2); @@ -4505,7 +4637,10 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i } else { /* Two complex expressions: */ generate_two_args(a2, a1, jitter, 0); - + CHECK_LIMIT(); + + mz_rs_sync(); + __START_SHORT_JUMPS__(branch_short); ref = jit_bner_p(jit_forward(), JIT_R0, JIT_R1); @@ -4597,6 +4732,8 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i generate_two_args(app->rand1, app->rand2, jitter, 1); CHECK_LIMIT(); + mz_rs_sync(); + if (!which) { /* vector-ref is relatively simple and worth inlining */ generate_vector_op(jitter, 0); @@ -4613,6 +4750,8 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i generate_non_tail(app->rand1, jitter, 0, 1); CHECK_LIMIT(); + + mz_rs_sync(); offset = SCHEME_INT_VAL(app->rand2); (void)jit_movi_p(JIT_R1, offset); @@ -4644,6 +4783,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i generate_two_args(app->rand1, app->rand2, jitter, 1); CHECK_LIMIT(); + mz_rs_sync(); __START_TINY_JUMPS__(1); ref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1); @@ -4674,6 +4814,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i generate_two_args(app->rand1, app->rand2, jitter, 1); CHECK_LIMIT(); + mz_rs_sync(); return generate_cons_alloc(jitter, 0, 0); } else if (IS_NAMED_PRIM(rator, "mcons")) { @@ -4681,6 +4822,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i generate_two_args(app->rand1, app->rand2, jitter, 1); CHECK_LIMIT(); + mz_rs_sync(); #ifdef CAN_INLINE_ALLOC /* Inlined alloc */ @@ -4707,12 +4849,13 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i generate_two_args(app->rand1, app->rand2, jitter, 1); CHECK_LIMIT(); - jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); + mz_rs_dec(1); CHECK_RUNSTACK_OVERFLOW(); mz_runstack_pushed(jitter, 1); - jit_str_p(JIT_RUNSTACK, JIT_R0); + mz_rs_str(JIT_R0); (void)jit_movi_p(JIT_R0, &scheme_null); CHECK_LIMIT(); + mz_rs_sync(); generate_cons_alloc(jitter, 1, 0); CHECK_LIMIT(); @@ -4741,6 +4884,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int is_tail, int multi_ok, jit_insn **for_branch, int branch_short) +/* de-sync's; for branch, sync'd before */ { Scheme_Object *rator = app->args[0]; @@ -4787,33 +4931,34 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int mz_runstack_skipped(jitter, 3 - pushed); if (pushed) { - jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(pushed)); + mz_rs_dec(pushed); CHECK_RUNSTACK_OVERFLOW(); mz_runstack_pushed(jitter, pushed); stack_safety(jitter, pushed, 0); CHECK_LIMIT(); } - generate_non_tail(app->args[1], jitter, 0, 1); + generate_non_tail(app->args[1], jitter, 0, 1); /* sync'd below */ CHECK_LIMIT(); if (!constval || !simple) { - jit_str_p(JIT_RUNSTACK, JIT_R0); + mz_rs_str(JIT_R0); } else { jit_movr_p(JIT_V1, JIT_R0); } if (!simple) { - generate_non_tail(app->args[2], jitter, 0, 1); + generate_non_tail(app->args[2], jitter, 0, 1); /* sync'd below */ CHECK_LIMIT(); if (!constval) { - jit_stxi_p(WORDS_TO_BYTES(1), JIT_RUNSTACK, JIT_R0); + mz_rs_stxi(1, JIT_R0); } else { jit_movr_p(JIT_R1, JIT_R0); } } - generate_non_tail(app->args[3], jitter, 0, 1); + generate_non_tail(app->args[3], jitter, 0, 1); /* sync'd below */ CHECK_LIMIT(); + mz_rs_sync(); if (!constval || !simple) { jit_movr_p(JIT_R2, JIT_R0); @@ -4855,7 +5000,7 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int } } - jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(pushed)); + mz_rs_inc(pushed); /* no sync */ mz_runstack_popped(jitter, pushed); mz_runstack_unskipped(jitter, 3 - pushed); @@ -4874,6 +5019,7 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int if (c) generate_app(app, NULL, c, jitter, 0, 0, 1); CHECK_LIMIT(); + mz_rs_sync(); #ifdef CAN_INLINE_ALLOC jit_movi_l(JIT_R2, c); @@ -4894,7 +5040,7 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int #endif if (c) { - jit_addi_l(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(c)); + mz_rs_inc(c); /* no sync */ mz_runstack_popped(jitter, c); } @@ -4949,6 +5095,7 @@ static int generate_cons_alloc(mz_jit_state *jitter, int rev, int inline_retry) static int generate_vector_alloc(mz_jit_state *jitter, Scheme_Object *rator, Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3) +/* de-sync'd ok */ { int imm, i, c; @@ -4956,20 +5103,22 @@ static int generate_vector_alloc(mz_jit_state *jitter, Scheme_Object *rator, if (app2) { mz_runstack_skipped(jitter, 1); - generate_non_tail(app2->rand, jitter, 0, 1); + generate_non_tail(app2->rand, jitter, 0, 1); /* sync'd below */ CHECK_LIMIT(); mz_runstack_unskipped(jitter, 1); c = 1; } else if (app3) { - generate_two_args(app3->rand1, app3->rand2, jitter, 1); + generate_two_args(app3->rand1, app3->rand2, jitter, 1); /* sync'd below */ c = 2; } else { c = app->num_args; if (c) - generate_app(app, NULL, c, jitter, 0, 0, 1); + generate_app(app, NULL, c, jitter, 0, 0, 1); /* sync'd below */ } CHECK_LIMIT(); + mz_rs_sync(); + #ifdef CAN_INLINE_ALLOC /* Inlined alloc */ if (app2) @@ -5027,6 +5176,7 @@ static int generate_vector_alloc(mz_jit_state *jitter, Scheme_Object *rator, } if (c) { + /* could use mz_rs */ jit_addi_l(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(c)); mz_runstack_popped(jitter, c); } @@ -5036,6 +5186,7 @@ static int generate_vector_alloc(mz_jit_state *jitter, Scheme_Object *rator, } int generate_inlined_test(mz_jit_state *jitter, Scheme_Object *obj, int branch_short, jit_insn **refs) +/* de-sync'd ok; syncs before jump */ { switch (SCHEME_TYPE(obj)) { case scheme_application2_type: @@ -5202,6 +5353,7 @@ static void ensure_case_closure_native(Scheme_Case_Lambda *c) } static int generate_case_closure(Scheme_Object *obj, mz_jit_state *jitter, int target) +/* de-sync's */ { Scheme_Case_Lambda *c = (Scheme_Case_Lambda *)obj; Scheme_Native_Closure_Data *ndata; @@ -5212,6 +5364,8 @@ static int generate_case_closure(Scheme_Object *obj, mz_jit_state *jitter, int t ensure_case_closure_native(c); ndata = c->native_code; + mz_rs_sync(); + JIT_UPDATE_THREAD_RSPTR_IF_NEEDED(); mz_prepare(1); retptr = mz_retain(ndata); @@ -5233,6 +5387,7 @@ static int generate_case_closure(Scheme_Object *obj, mz_jit_state *jitter, int t o = (Scheme_Object *)((Scheme_Closure *)o)->code; data = (Scheme_Closure_Data *)o; mz_pushr_p(JIT_R1); + mz_rs_sync(); generate_closure(data, jitter, 1); CHECK_LIMIT(); generate_closure_fill(data, jitter); @@ -5253,7 +5408,8 @@ static int generate_case_closure(Scheme_Object *obj, mz_jit_state *jitter, int t static int generate_non_tail_mark_pos_prefix(mz_jit_state *jitter) { - /* This part of a non-tail setup can be done once for a sequence + /* dsync'd ok. + This part of a non-tail setup can be done once for a sequence of non-tail calls. In that case, pass 0 for the `mark_pos_ends' argument to generate_non_tail(), so that it can skip this prefix and suffix. In case this prefix needs to adjust the runstack, @@ -5265,6 +5421,7 @@ static int generate_non_tail_mark_pos_prefix(mz_jit_state *jitter) } static void generate_non_tail_mark_pos_suffix(mz_jit_state *jitter) +/* dsync'd ok */ { jit_ldi_l(JIT_R2, &scheme_current_cont_mark_pos); jit_subi_l(JIT_R2, JIT_R2, 2); @@ -5272,6 +5429,7 @@ static void generate_non_tail_mark_pos_suffix(mz_jit_state *jitter) } static int generate_non_tail(Scheme_Object *obj, mz_jit_state *jitter, int multi_ok, int mark_pos_ends) +/* de-sync's rs */ { if (is_simple(obj, INIT_SIMPLE_DEPTH, 0, jitter, 0)) { /* Simple; doesn't change the stack or set marks: */ @@ -5302,7 +5460,7 @@ static int generate_non_tail(Scheme_Object *obj, mz_jit_state *jitter, int multi /* mark stack is an integer... turn it into a pointer */ jit_lshi_l(JIT_R2, JIT_R2, 0x1); jit_ori_l(JIT_R2, JIT_R2, 0x1); - mz_pushr_p(JIT_R2); + mz_pushr_p(JIT_R2); /* no sync */ } CHECK_LIMIT(); } @@ -5312,7 +5470,7 @@ static int generate_non_tail(Scheme_Object *obj, mz_jit_state *jitter, int multi PAUSE_JIT_DATA(); FOR_LOG(jitter->log_depth++); - generate(obj, jitter, 0, multi_ok, JIT_R0); + generate(obj, jitter, 0, multi_ok, JIT_R0); /* no sync */ FOR_LOG(--jitter->log_depth); RESUME_JIT_DATA(); @@ -5320,14 +5478,14 @@ static int generate_non_tail(Scheme_Object *obj, mz_jit_state *jitter, int multi amt = mz_runstack_restored(jitter); if (amt) { - jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(amt)); + mz_rs_inc(amt); } if (need_ends) { if (using_local1) { mz_get_local_p(JIT_R2, JIT_LOCAL1); jitter->local1_busy = 0; } else { - mz_popr_p(JIT_R2); + mz_popr_p(JIT_R2); /* no sync */ jit_rshi_l(JIT_R2, JIT_R2, 0x1); /* pointer back to integer */ } jit_sti_p(&scheme_current_cont_mark_stack, JIT_R2); @@ -5347,6 +5505,7 @@ static int generate_non_tail(Scheme_Object *obj, mz_jit_state *jitter, int multi /*========================================================================*/ static int generate_ignored_non_tail(Scheme_Object *obj, mz_jit_state *jitter, int multi_ok, int need_ends) +/* de-sync's */ { Scheme_Type t = SCHEME_TYPE(obj); @@ -5358,7 +5517,7 @@ static int generate_ignored_non_tail(Scheme_Object *obj, mz_jit_state *jitter, i START_JIT_DATA(); pos = mz_remap(SCHEME_LOCAL_POS(obj)); LOG_IT(("clear %d\n", pos)); - jit_stxi_p(WORDS_TO_BYTES(pos), JIT_RUNSTACK, JIT_RUNSTACK); + mz_rs_stxi(pos, JIT_RUNSTACK); END_JIT_DATA(2); } return 1; @@ -5383,7 +5542,7 @@ static Scheme_Object *generate_k(void) } static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int multi_ok, int target) -/* result goes to JIT_R0 */ +/* de-sync's; result goes to target */ { Scheme_Type type; @@ -5422,9 +5581,10 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m /* Other parts of the JIT rely on this code not modifying R1 */ START_JIT_DATA(); LOG_IT(("top-level\n")); + mz_rs_sync(); /* Load global array: */ pos = mz_remap(SCHEME_TOPLEVEL_DEPTH(obj)); - jit_ldxi_p(JIT_R2, JIT_RUNSTACK, WORDS_TO_BYTES(pos)); + mz_rs_ldxi(JIT_R2, pos); /* Load bucket: */ pos = SCHEME_TOPLEVEL_POS(obj); jit_ldxi_p(JIT_R2, JIT_R2, WORDS_TO_BYTES(pos)); @@ -5447,13 +5607,13 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m pos = mz_remap(SCHEME_LOCAL_POS(obj)); LOG_IT(("local %d [%d]\n", pos, SCHEME_LOCAL_FLAGS(obj))); if (pos || (mz_CURRENT_STATUS() != mz_RS_R0_HAS_RUNSTACK0)) { - jit_ldxi_p(target, JIT_RUNSTACK, WORDS_TO_BYTES(pos)); + mz_rs_ldxi(target, pos); VALIDATE_RESULT(target); } else if (target != JIT_R0) { jit_movr_p(target, JIT_R0); } if (SCHEME_LOCAL_FLAGS(obj) & SCHEME_LOCAL_CLEAR_ON_READ) { - jit_stxi_p(WORDS_TO_BYTES(pos), JIT_RUNSTACK, JIT_RUNSTACK); + mz_rs_stxi(pos, JIT_RUNSTACK); } END_JIT_DATA(2); return 1; @@ -5465,11 +5625,11 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m LOG_IT(("unbox local\n")); pos = mz_remap(SCHEME_LOCAL_POS(obj)); - jit_ldxi_p(JIT_R0, JIT_RUNSTACK, WORDS_TO_BYTES(pos)); + mz_rs_ldxi(JIT_R0, pos); jit_ldr_p(target, JIT_R0); if (SCHEME_LOCAL_FLAGS(obj) & SCHEME_LOCAL_CLEAR_ON_READ) { LOG_IT(("clear-on-read\n")); - jit_stxi_p(WORDS_TO_BYTES(pos), JIT_RUNSTACK, JIT_RUNSTACK); + mz_rs_stxi(pos, JIT_RUNSTACK); } VALIDATE_RESULT(target); @@ -5479,6 +5639,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m case scheme_syntax_type: { int pos; + mz_rs_sync(); pos = SCHEME_PINT_VAL(obj); switch (pos) { case CASE_LAMBDA_EXPD: @@ -5505,17 +5666,19 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m evaluation, allow multiple values. */ generate_non_tail(seq->array[0], jitter, 1, 1); CHECK_LIMIT(); + mz_rs_sync(); /* Save value(s) */ jit_movr_p(JIT_V1, JIT_R0); mz_pushr_p(JIT_V1); mz_pushr_p(JIT_V1); mz_pushr_p(JIT_V1); + mz_rs_sync(); __START_SHORT_JUMPS__(1); ref = jit_bnei_p(jit_forward(), JIT_R0, SCHEME_MULTIPLE_VALUES); CHECK_LIMIT(); /* Save away multiple values */ - mz_popr_p(JIT_V1); + mz_popr_p(JIT_V1); /* sync'd below... */ mz_popr_p(JIT_V1); mz_popr_p(JIT_V1); jit_ldi_p(JIT_R0, &scheme_current_thread); @@ -5523,14 +5686,15 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m jit_ldxi_l(JIT_V1, JIT_R0, &((Scheme_Thread *)0x0)->ku.multiple.count); jit_lshi_l(JIT_V1, JIT_V1, 0x1); jit_ori_l(JIT_V1, JIT_V1, 0x1); - mz_pushr_p(JIT_V1); + mz_pushr_p(JIT_V1); /* sync'd below */ jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Thread *)0x0)->ku.multiple.array); - mz_pushr_p(JIT_V1); + mz_pushr_p(JIT_V1); /* sync'd below */ CHECK_LIMIT(); (void)jit_movi_p(JIT_R1, 0x0); mz_pushr_p(JIT_R1); /* pushing 0 indicates that multi-array follows */ /* If multi-value array is values buffer, zero out values buffer */ jit_ldxi_p(JIT_R2, JIT_R0, &((Scheme_Thread *)0x0)->values_buffer); + mz_rs_sync(); ref2 = jit_bner_p(jit_forward(), JIT_V1, JIT_R2); jit_stxi_p(&((Scheme_Thread *)0x0)->values_buffer, JIT_R0, JIT_R1); CHECK_LIMIT(); @@ -5540,7 +5704,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m mz_patch_branch(ref2); __END_SHORT_JUMPS__(1); for (i = 1; i < seq->count; i++) { - generate_ignored_non_tail(seq->array[i], jitter, 1, 1); + generate_ignored_non_tail(seq->array[i], jitter, 1, 1); /* sync's below */ CHECK_LIMIT(); } @@ -5548,6 +5712,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m mz_popr_p(JIT_R0); mz_popr_p(JIT_R1); mz_popr_p(JIT_R2); + mz_rs_sync(); CHECK_LIMIT(); __START_TINY_JUMPS__(1); ref = jit_bnei_p(jit_forward(), JIT_R0, 0x0); @@ -5583,7 +5748,8 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m generate_non_tail(p, jitter, 0, 1); CHECK_LIMIT(); - + mz_rs_sync(); + /* Load global+stx array: */ pos = mz_remap(SCHEME_TOPLEVEL_DEPTH(v)); jit_ldxi_p(JIT_R2, JIT_RUNSTACK, WORDS_TO_BYTES(pos)); @@ -5620,7 +5786,8 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m generate_non_tail(v, jitter, 0, 1); CHECK_LIMIT(); - + mz_rs_sync(); + /* If v is not known to produce a procedure, then check result: */ if (!is_a_procedure(v, jitter)) { (void)jit_bmsi_l(bad_app_vals_target, JIT_R0, 0x1); @@ -5637,6 +5804,8 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m mz_popr_p(JIT_V1); /* Function is in V1, argument(s) in R0 */ + mz_rs_sync(); + __START_SHORT_JUMPS__(1); ref = jit_beqi_p(jit_forward(), JIT_R0, SCHEME_MULTIPLE_VALUES); /* Single-value case: --------------- */ @@ -5939,6 +6108,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m if (!generate_inlined_test(jitter, branch->test, then_short_ok, refs)) { CHECK_LIMIT(); generate_non_tail(branch->test, jitter, 0, 1); + mz_rs_sync(); CHECK_LIMIT(); __START_SHORT_JUMPS__(then_short_ok); refs[0] = jit_beqi_p(jit_forward(), JIT_R0, scheme_false); @@ -5957,9 +6127,11 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m CHECK_LIMIT(); amt = mz_runstack_restored(jitter); if (g1 != 2) { - if (amt && !is_tail) { - jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(amt)); - } + if (!is_tail) { + if (amt) + mz_rs_inc(amt); + mz_rs_sync(); + } __START_SHORT_JUMPS__(else_short_ok); ref2 = jit_jmpi(jit_forward()); __END_SHORT_JUMPS__(else_short_ok); @@ -5969,7 +6141,8 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m nsrs1 = 0; } jitter->need_set_rs = nsrs; - + mz_rs_sync_0(); + /* False branch */ mz_runstack_saved(jitter); __START_SHORT_JUMPS__(then_short_ok); @@ -6001,9 +6174,11 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m CHECK_LIMIT(); amt = mz_runstack_restored(jitter); if (g2 != 2) { - if (amt && !is_tail) { - jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(amt)); - } + if (!is_tail) { + if (amt) + mz_rs_inc(amt); + mz_rs_sync(); + } } else { jitter->need_set_rs = 0; } @@ -6033,6 +6208,8 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m LOG_IT(("lambda\n")); + mz_rs_sync(); + /* Allocate closure */ generate_closure(data, jitter, 1); CHECK_LIMIT(); @@ -6056,15 +6233,15 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m if (lv->count == 1) { /* Expect one result: */ - generate_non_tail(lv->value, jitter, 0, 1); + generate_non_tail(lv->value, jitter, 0, 1); /* no sync */ CHECK_LIMIT(); if (ab) { pos = mz_remap(lv->position); - jit_ldxi_p(JIT_R2, JIT_RUNSTACK, WORDS_TO_BYTES(pos)); + mz_rs_ldxi(JIT_R2, pos); jit_str_p(JIT_R2, JIT_R0); } else { pos = mz_remap(lv->position); - jit_stxi_p(WORDS_TO_BYTES(pos), JIT_RUNSTACK, JIT_R0); + mz_rs_stxi(pos, JIT_R0); } CHECK_LIMIT(); } else { @@ -6073,6 +6250,8 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m generate_non_tail(lv->value, jitter, 1, 1); CHECK_LIMIT(); + + mz_rs_sync(); __START_SHORT_JUMPS__(1); @@ -6139,13 +6318,14 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m LOG_IT(("letv...\n")); - jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(c)); + mz_rs_dec(c); CHECK_RUNSTACK_OVERFLOW(); stack_safety(jitter, c, 0); mz_runstack_pushed(jitter, c); if (SCHEME_LET_AUTOBOX(lv)) { int i; + mz_rs_sync(); JIT_UPDATE_THREAD_RSPTR_IF_NEEDED(); for (i = 0; i < c; i++) { CHECK_LIMIT(); @@ -6173,6 +6353,8 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m LOG_IT(("letrec...\n")); + mz_rs_sync(); + /* Create unfinished closures */ for (i = 0; i < l->count; i++) { ((Scheme_Closure_Data *)l->procs[i])->context = (Scheme_Object *)l; @@ -6228,17 +6410,17 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m mz_runstack_skipped(jitter, 1); PAUSE_JIT_DATA(); - generate_non_tail(lv->value, jitter, 0, 1); + generate_non_tail(lv->value, jitter, 0, 1); /* no sync */ RESUME_JIT_DATA(); CHECK_LIMIT(); mz_runstack_unskipped(jitter, 1); - jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); + mz_rs_dec(1); CHECK_RUNSTACK_OVERFLOW(); mz_runstack_pushed(jitter, 1); - jit_str_p(JIT_RUNSTACK, JIT_R0); + mz_rs_str(JIT_R0); END_JIT_DATA(17); @@ -6256,20 +6438,21 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m LOG_IT(("wcm...\n")); /* Key: */ - generate_non_tail(wcm->key, jitter, 0, 1); + generate_non_tail(wcm->key, jitter, 0, 1); /* sync'd below */ CHECK_LIMIT(); if (SCHEME_TYPE(wcm->val) > _scheme_values_types_) { /* No need to push mark onto value stack: */ jit_movr_p(JIT_V1, JIT_R0); - generate_non_tail(wcm->val, jitter, 0, 1); + generate_non_tail(wcm->val, jitter, 0, 1); /* sync'd below */ CHECK_LIMIT(); } else { mz_pushr_p(JIT_R0); - generate_non_tail(wcm->val, jitter, 0, 1); + generate_non_tail(wcm->val, jitter, 0, 1); /* sync'd below */ CHECK_LIMIT(); - mz_popr_p(JIT_V1); + mz_popr_p(JIT_V1); /* sync'd below */ } + mz_rs_sync(); JIT_UPDATE_THREAD_RSPTR_IF_NEEDED(); mz_prepare(2); @@ -6295,7 +6478,9 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m i = qs->position; c = mz_remap(qs->depth); p = qs->midpoint; - + + mz_rs_sync(); + jit_movi_i(JIT_R0, WORDS_TO_BYTES(c)); jit_movi_i(JIT_R1, WORDS_TO_BYTES(i + p + 1)); jit_movi_i(JIT_R2, WORDS_TO_BYTES(p)); @@ -7481,7 +7666,7 @@ static int generate_alloc_retry(mz_jit_state *jitter, int i) typedef struct { Scheme_Closure_Data *data; - void *code, *tail_code, *code_end, **patch_depth; + void *arity_code, *code, *tail_code, *code_end, **patch_depth; int max_extra, max_depth; Scheme_Native_Closure *nc; } Generate_Closure_Data; @@ -7490,8 +7675,8 @@ 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; - int i, r, cnt, has_rest; + void *code, *tail_code, *code_end, *arity_code; + int i, r, cnt, has_rest, is_method, num_params; code = jit_get_ip().ptr; @@ -7507,7 +7692,35 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data) (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST), data->num_params); CHECK_LIMIT(); + + /* A tail call with arity checking can start here. + (This is a little reundant checking when `code' is the + etry point, but that's the slow path anyway.) */ + has_rest = ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) ? 1 : 0); + is_method = ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_IS_METHOD) ? 1 : 0); + num_params = data->num_params; + if (num_params && has_rest) + --num_params; + + if (num_params < MAX_SHARED_ARITY_CHECK) { + void *shared_arity_code; + + shared_arity_code = shared_arity_check[num_params][has_rest][is_method]; + if (!shared_arity_code) { + shared_arity_code = generate_lambda_simple_arity_check(num_params, has_rest, is_method, 1); + shared_arity_check[num_params][has_rest][is_method] = shared_arity_code; + } + + arity_code = jit_get_ip().ptr; + + if (!has_rest) + (void)jit_bnei_i(shared_arity_code, JIT_R1, num_params); + else + (void)jit_blti_i(shared_arity_code, JIT_R1, num_params); + } else + arity_code = generate_lambda_simple_arity_check(num_params, has_rest, is_method, 0); + /* A tail call starts here. Caller must ensure that the stack is big enough, right number of arguments, closure is in R0. If the closure has a rest arg, also ensure @@ -7517,8 +7730,7 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data) /* 0 params and has_rest => (lambda args E) where args is not in E, so accept any number of arguments and ignore them. */ - if ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) - && data->num_params) { + if (has_rest && data->num_params) { /* If runstack == argv and argc == cnt, then we didn't copy args down, and we need to make room for scheme_null. */ jit_insn *ref, *ref2, *ref3; @@ -7547,7 +7759,10 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data) #ifndef JIT_PRECISE_GC if (data->closure_size) #endif - mz_pushr_p(JIT_R0); + { + mz_pushr_p(JIT_R0); + mz_rs_sync(); + } JIT_UPDATE_THREAD_RSPTR(); CHECK_LIMIT(); mz_prepare(3); @@ -7561,7 +7776,10 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data) #ifndef JIT_PRECISE_GC if (data->closure_size) #endif - mz_popr_p(JIT_R0); + { + mz_popr_p(JIT_R0); + mz_rs_sync(); + } jit_stxi_p(WORDS_TO_BYTES(cnt), JIT_RUNSTACK, JIT_V1); mz_patch_ucbranch(ref2); /* jump here if we copied and produced null */ CHECK_LIMIT(); @@ -7576,24 +7794,26 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data) /* 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); + mz_pushr_p(JIT_R0); /* no sync */ #endif /* Extract closure to runstack: */ cnt = data->closure_size; if (cnt) { - jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(cnt)); + mz_rs_dec(cnt); CHECK_RUNSTACK_OVERFLOW(); for (i = cnt; i--; ) { int pos; pos = WORDS_TO_BYTES(i) + (long)&((Scheme_Native_Closure *)0x0)->vals; jit_ldxi_p(JIT_R1, JIT_R0, pos); - jit_stxi_p(WORDS_TO_BYTES(i), JIT_RUNSTACK, JIT_R1); + mz_rs_stxi(i, JIT_R1); CHECK_LIMIT(); } } + mz_rs_sync(); + /* If we have a letrec context, record arities */ if (data->context && SAME_TYPE(SCHEME_TYPE(data->context), scheme_letrec_type)) { Scheme_Letrec *lr = (Scheme_Letrec *)data->context; @@ -7649,7 +7869,7 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data) /* Generate code for the body: */ jitter->need_set_rs = 1; - r = generate(data->code, jitter, 1, 1, JIT_R0); + r = generate(data->code, jitter, 1, 1, JIT_R0); /* no need for sync */ /* Result is in JIT_R0 */ CHECK_LIMIT(); @@ -7664,6 +7884,7 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data) code_end = jit_get_ip().ptr; if (jitter->retain_start) { + gdata->arity_code = arity_code; gdata->code = code; gdata->tail_code = tail_code; gdata->max_extra = jitter->max_extra_pushed; @@ -7681,7 +7902,7 @@ static void on_demand_generate_lambda(Scheme_Native_Closure *nc) Scheme_Closure_Data *data; Generate_Closure_Data gdata; void *code, *tail_code, *arity_code; - int has_rest, is_method, num_params, max_depth; + int max_depth; data = ndata->u2.orig_code; @@ -7702,6 +7923,7 @@ static void on_demand_generate_lambda(Scheme_Native_Closure *nc) if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_SINGLE_RESULT) SCHEME_NATIVE_CLOSURE_DATA_FLAGS(ndata) |= NATIVE_IS_SINGLE_RESULT; + arity_code = gdata.arity_code; code = gdata.code; tail_code = gdata.tail_code; @@ -7713,21 +7935,6 @@ static void on_demand_generate_lambda(Scheme_Native_Closure *nc) #endif } - has_rest = ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) ? 1 : 0); - is_method = ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_IS_METHOD) ? 1 : 0); - num_params = data->num_params; - if (num_params && has_rest) - --num_params; - - if (num_params < MAX_SHARED_ARITY_CHECK) { - arity_code = shared_arity_check[num_params][has_rest][is_method]; - if (!arity_code) { - arity_code = generate_lambda_simple_arity_check(num_params, has_rest, is_method, 1); - shared_arity_check[num_params][has_rest][is_method] = arity_code; - } - } else - arity_code = generate_lambda_simple_arity_check(num_params, has_rest, is_method, 0); - /* Add a couple of extra slots to computed let-depth, in case we haven't quite computed right for inlined uses, etc. */ max_depth = WORDS_TO_BYTES(data->max_let_depth + gdata.max_extra + 2); diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index 2398ea2ba4..9b8a595c3c 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -116,7 +116,8 @@ static void eval_exptime(Scheme_Object *names, int count, Scheme_Env *genv, Scheme_Comp_Env *env, Resolve_Prefix *rp, int let_depth, int shift, Scheme_Bucket_Table *syntax, int for_stx, - Scheme_Object *certs); + Scheme_Object *certs, + Scheme_Object *free_id_rename_rn); static Scheme_Module_Exports *make_module_exports(); @@ -156,6 +157,7 @@ static Scheme_Object *lib_symbol; static Scheme_Object *planet_symbol; static Scheme_Object *file_symbol; static Scheme_Object *module_name_symbol; +static Scheme_Object *nominal_id_symbol; /* global read-only syntax */ Scheme_Object *scheme_module_stx; @@ -565,6 +567,9 @@ void scheme_finish_kernel(Scheme_Env *env) REGISTER_SO(module_name_symbol); module_name_symbol = scheme_intern_symbol("enclosing-module-name"); + + REGISTER_SO(nominal_id_symbol); + nominal_id_symbol = scheme_intern_symbol("nominal-id"); } int scheme_is_kernel_modname(Scheme_Object *modname) @@ -3947,7 +3952,7 @@ void scheme_run_module_exptime(Scheme_Env *menv, int set_ns) eval_exptime(names, scheme_list_length(names), e, exp_env, rhs_env, rp, let_depth, 1, (for_stx ? for_stx_globals : syntax), for_stx, - NULL); + NULL, scheme_false); } if (set_ns) { @@ -4401,13 +4406,15 @@ static void *eval_exptime_k(void) Resolve_Prefix *rp; int let_depth, shift; Scheme_Bucket_Table *syntax; + Scheme_Object *free_id_rename_rn; names = (Scheme_Object *)p->ku.k.p1; expr = (Scheme_Object *)p->ku.k.p2; genv = (Scheme_Env *)SCHEME_CAR((Scheme_Object *)p->ku.k.p3); comp_env = (Scheme_Comp_Env *)SCHEME_CDR((Scheme_Object *)p->ku.k.p3); - rp = (Resolve_Prefix *)SCHEME_CAR((Scheme_Object *)p->ku.k.p4); - syntax = (Scheme_Bucket_Table *)SCHEME_CDR((Scheme_Object *)p->ku.k.p4); + free_id_rename_rn = SCHEME_CAR((Scheme_Object *)p->ku.k.p4); + rp = (Resolve_Prefix *)SCHEME_CAR(SCHEME_CDR((Scheme_Object *)p->ku.k.p4)); + syntax = (Scheme_Bucket_Table *)SCHEME_CDR(SCHEME_CDR((Scheme_Object *)p->ku.k.p4)); count = p->ku.k.i1; let_depth = p->ku.k.i2; shift = p->ku.k.i3; @@ -4420,7 +4427,8 @@ static void *eval_exptime_k(void) p->ku.k.p4 = NULL; p->ku.k.p5 = NULL; - eval_exptime(names, count, expr, genv, comp_env, rp, let_depth, shift, syntax, for_stx, certs); + eval_exptime(names, count, expr, genv, comp_env, rp, let_depth, shift, syntax, for_stx, + certs, free_id_rename_rn); return NULL; } @@ -4441,7 +4449,8 @@ static void eval_exptime(Scheme_Object *names, int count, Scheme_Env *genv, Scheme_Comp_Env *comp_env, Resolve_Prefix *rp, int let_depth, int shift, Scheme_Bucket_Table *syntax, - int for_stx, Scheme_Object *certs) + int for_stx, Scheme_Object *certs, + Scheme_Object *free_id_rename_rn) { Scheme_Object *macro, *vals, *name, **save_runstack; int i, g, depth; @@ -4454,6 +4463,7 @@ static void eval_exptime(Scheme_Object *names, int count, vals = scheme_make_pair((Scheme_Object *)genv, (Scheme_Object *)comp_env); p->ku.k.p3 = vals; vals = scheme_make_pair((Scheme_Object *)rp, (Scheme_Object *)syntax); + vals = scheme_make_pair(free_id_rename_rn, vals); p->ku.k.p4 = vals; p->ku.k.i1 = count; p->ku.k.i2 = let_depth; @@ -4511,6 +4521,11 @@ static void eval_exptime(Scheme_Object *names, int count, macro = scheme_alloc_small_object(); macro->type = scheme_macro_type; SCHEME_PTR_VAL(macro) = values[i]; + + if (SCHEME_TRUEP(free_id_rename_rn) + && scheme_is_binding_rename_transformer(values[i])) + scheme_install_free_id_rename(name, scheme_rename_transformer_id(values[i]), free_id_rename_rn, + scheme_make_integer(0)); } else macro = values[i]; @@ -4526,6 +4541,11 @@ static void eval_exptime(Scheme_Object *names, int count, macro = scheme_alloc_small_object(); macro->type = scheme_macro_type; SCHEME_PTR_VAL(macro) = vals; + + if (SCHEME_TRUEP(free_id_rename_rn) + && scheme_is_binding_rename_transformer(vals)) + scheme_install_free_id_rename(name, scheme_rename_transformer_id(vals), free_id_rename_rn, + scheme_make_integer(0)); } else macro = vals; @@ -6170,6 +6190,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, Optimize_Info *oi; int count = 0; int for_stx; + int use_post_ex = 0; for_stx = scheme_stx_module_eq(define_for_syntaxes_stx, fst, 0); @@ -6233,6 +6254,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, 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); *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); @@ -6304,8 +6326,9 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, eval_exptime(names, count, m, eenv->genv, rhs_env, rp, ri->max_let_depth, 0, (for_stx ? env->genv->exp_env->toplevel : env->genv->syntax), for_stx, - rec[drec].certs); - + rec[drec].certs, + for_stx ? scheme_false : (use_post_ex ? post_ex_rn : rn)); + if (rec[drec].comp) e = NULL; else { @@ -6369,11 +6392,11 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, } /* first = a list of (cons semi-expanded-expression kind) */ - /* Bound names will be re-bound at this point: */ + /* Bound names will not be re-bound at this point: */ if (rec[drec].comp || (rec[drec].depth != -2)) { scheme_seal_module_rename_set(rn_set, STX_SEAL_BOUND); - scheme_seal_module_rename_set(post_ex_rn_set, STX_SEAL_BOUND); } + scheme_seal_module_rename_set(post_ex_rn_set, STX_SEAL_BOUND); /* Pass 2 */ SCHEME_EXPAND_OBSERVE_NEXT_GROUP(observer); @@ -6534,8 +6557,8 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, if (rec[drec].comp || (rec[drec].depth != -2)) { scheme_seal_module_rename_set(rn_set, STX_SEAL_ALL); - scheme_seal_module_rename_set(post_ex_rn_set, STX_SEAL_ALL); } + 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, @@ -7315,6 +7338,72 @@ static Scheme_Object *adjust_for_rename(Scheme_Object *out_name, Scheme_Object * return first; } +static Scheme_Object *extract_free_id_name(Scheme_Object *name, + Scheme_Object *phase, + Scheme_Env *genv, + int always, + int *_implicit, + Scheme_Object **_implicit_src, + Scheme_Object **_implicit_src_name, + Scheme_Object **_implicit_mod_phase, + Scheme_Object **_implicit_nominal_name, + Scheme_Object **_implicit_nominal_mod) +{ + *_implicit = 0; + + while (1) { /* loop for free-id=? renaming */ + if (SCHEME_STXP(name)) { + if (genv + && (always + || SAME_OBJ(phase, scheme_make_integer(0)) + || SAME_OBJ(phase, scheme_make_integer(1)))) + name = scheme_tl_id_sym(genv, name, NULL, -1, phase, NULL); + else + name = SCHEME_STX_VAL(name); /* shouldn't get here; no `define-for-label' */ + } + + /* Check for free-id=? renaming: */ + if (SAME_OBJ(phase, scheme_make_integer(0))) { + Scheme_Object *v2; + 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; + + name2 = scheme_rename_transformer_id(SCHEME_PTR_VAL(v2)); + id = name2; + mod = scheme_stx_module_name(0, &id, phase, + _implicit_nominal_mod, _implicit_nominal_name, + _implicit_mod_phase, + NULL, NULL, NULL, NULL); + if (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; + } + *_implicit = 1; + break; + } + } else + break; + } else + break; + } else + break; + } + + return name; +} + char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table *tables, Scheme_Module_Exports *me, Scheme_Env *genv, @@ -7322,13 +7411,15 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table Scheme_Object *form, char **_phase1_protects) { - int i, count, z; + int i, count, z, implicit; Scheme_Object **exs, **exsns, **exss, **exsnoms, *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; + for (z = 0; z < all_provided->size; z++) { provided = (Scheme_Hash_Table *)all_provided->vals[z]; @@ -7381,16 +7472,14 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table v = provided->vals[i]; /* external name */ name = SCHEME_CAR(v); /* internal name (maybe already a symbol) */ protected = SCHEME_TRUEP(SCHEME_CDR(v)); - prnt_name = name; - if (SCHEME_STXP(name)) { - if (genv) - name = scheme_tl_id_sym(genv, name, NULL, -1, phase, NULL); - else - name = SCHEME_STX_VAL(name); /* shouldn't get here; no `define-for-label' */ - } - if (genv + name = extract_free_id_name(name, phase, genv, 1, &implicit, + NULL, NULL, NULL, + NULL, NULL); + + if (!implicit + && genv && (SAME_OBJ(phase, scheme_make_integer(0)) || SAME_OBJ(phase, scheme_make_integer(1))) && scheme_lookup_in_table(SAME_OBJ(phase, scheme_make_integer(0)) @@ -7406,10 +7495,13 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table if (SAME_OBJ(phase, scheme_make_integer(1))) exets[count] = 1; count++; - } else if (genv + } else if (!implicit + && genv && SAME_OBJ(phase, scheme_make_integer(0)) && scheme_lookup_in_table(genv->syntax, (const char *)name)) { - /* Skip for now. */ + /* Skip syntax for now. */ + } else if (implicit) { + /* Rename-transformer redirect; skip for now. */ } else if ((v = scheme_hash_get(required, name))) { /* Required */ if (protected) { @@ -7454,17 +7546,13 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table name = SCHEME_CAR(v); /* internal name (maybe already a symbol) */ protected = SCHEME_TRUEP(SCHEME_CDR(v)); - if (SCHEME_STXP(name)) { - if (genv - && (SAME_OBJ(phase, scheme_make_integer(0)) - || SAME_OBJ(phase, scheme_make_integer(1)))) - name = scheme_tl_id_sym(genv, name, NULL, -1, phase, NULL); - else { - name = SCHEME_STX_VAL(name); /* shouldn't get here; no `define-for-label' */ - } - } + name = extract_free_id_name(name, phase, genv, 0, &implicit, + &implicit_src, &implicit_src_name, + &implicit_mod_phase, + &implicit_nominal_name, &implicit_nominal_mod); - if (genv + if (!implicit + && genv && SAME_OBJ(phase, scheme_make_integer(0)) && scheme_lookup_in_table(genv->syntax, (const char *)name)) { /* Defined locally */ @@ -7474,6 +7562,16 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table exsnoms[count] = scheme_null; /* since "self" */ exps[count] = protected; count++; + } else if (implicit) { + /* We record all free-id=?-based exprts as synatx, 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; + count++; } else if ((v = scheme_hash_get(required, name))) { /* Required */ if (SCHEME_FALSEP(SCHEME_VEC_ELS(v)[3])) { @@ -8441,7 +8539,7 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */ exets ? exets[j] : 0, src_phase_index, pt->phase_index, - for_unmarshal || (!has_context && can_save_marshal)); + (for_unmarshal || (!has_context && can_save_marshal)) ? 1 : 0); } } } diff --git a/src/mzscheme/src/mzmark.c b/src/mzscheme/src/mzmark.c index 64c2337deb..53565447b8 100644 --- a/src/mzscheme/src/mzmark.c +++ b/src/mzscheme/src/mzmark.c @@ -1649,6 +1649,7 @@ static int thread_val_MARK(void *p) { gcMARK(pr->current_mt); gcMARK(pr->constant_folding); + gcMARK(pr->reading_delayed); gcMARK(pr->overflow_reply); @@ -1759,6 +1760,7 @@ static int thread_val_FIXUP(void *p) { gcFIXUP(pr->current_mt); gcFIXUP(pr->constant_folding); + gcFIXUP(pr->reading_delayed); gcFIXUP(pr->overflow_reply); @@ -5036,6 +5038,7 @@ static int mark_rename_table_MARK(void *p) { gcMARK(rn->plus_kernel_nominal_source); gcMARK(rn->set_identity); gcMARK(rn->marked_names); + gcMARK(rn->free_id_renames); return gcBYTES_TO_WORDS(sizeof(Module_Renames)); } @@ -5050,6 +5053,7 @@ static int mark_rename_table_FIXUP(void *p) { gcFIXUP(rn->plus_kernel_nominal_source); gcFIXUP(rn->set_identity); gcFIXUP(rn->marked_names); + gcFIXUP(rn->free_id_renames); return gcBYTES_TO_WORDS(sizeof(Module_Renames)); } diff --git a/src/mzscheme/src/mzmarksrc.c b/src/mzscheme/src/mzmarksrc.c index a49b33ab01..f8f0dd3a37 100644 --- a/src/mzscheme/src/mzmarksrc.c +++ b/src/mzscheme/src/mzmarksrc.c @@ -662,6 +662,7 @@ thread_val { gcMARK(pr->current_mt); gcMARK(pr->constant_folding); + gcMARK(pr->reading_delayed); gcMARK(pr->overflow_reply); @@ -689,6 +690,7 @@ thread_val { gcMARK(pr->private_kill_next); gcMARK(pr->user_tls); + gcMARK(pr->gmp_tls_data); gcMARK(pr->mr_hop); gcMARK(pr->mref); @@ -2068,6 +2070,7 @@ mark_rename_table { gcMARK(rn->plus_kernel_nominal_source); gcMARK(rn->set_identity); gcMARK(rn->marked_names); + gcMARK(rn->free_id_renames); size: gcBYTES_TO_WORDS(sizeof(Module_Renames)); } diff --git a/src/mzscheme/src/print.c b/src/mzscheme/src/print.c index 8bf974c8bd..5a67a701d4 100644 --- a/src/mzscheme/src/print.c +++ b/src/mzscheme/src/print.c @@ -120,6 +120,8 @@ static Scheme_Object *writable_struct_subs(Scheme_Object *s, int for_write, Prin #define PRINTABLE_STRUCT(obj, pp) (scheme_inspector_sees_part(obj, pp->inspector, -1)) #define SCHEME_PREFABP(obj) (((Scheme_Structure *)(obj))->stype->prefab_key) +#define SCHEME_HASHTPx(obj) ((SCHEME_HASHTP(obj) && !(MZ_OPT_HASH_KEY(&(((Scheme_Hash_Table *)obj)->iso)) & 0x1))) + #define HAS_SUBSTRUCT(obj, qk) \ (SCHEME_PAIRP(obj) \ || SCHEME_MUTABLE_PAIRP(obj) \ @@ -129,7 +131,7 @@ static Scheme_Object *writable_struct_subs(Scheme_Object *s, int for_write, Prin && SCHEME_STRUCTP(obj) \ && PRINTABLE_STRUCT(obj, pp), 0)) \ || (qk(SCHEME_STRUCTP(obj) && scheme_is_writable_struct(obj), 0)) \ - || (qk(pp->print_hash_table, 1) && (SCHEME_HASHTP(obj) || SCHEME_HASHTRP(obj)))) + || (qk(pp->print_hash_table, 1) && (SCHEME_HASHTPx(obj) || SCHEME_HASHTRP(obj)))) #define ssQUICK(x, isbox) x #define ssQUICKp(x, isbox) (pp ? x : isbox) #define ssALL(x, isbox) 1 @@ -486,7 +488,7 @@ static int check_cycles(Scheme_Object *obj, int for_write, Scheme_Hash_Table *ht } } } - } else if (SCHEME_HASHTP(obj)) { + } else if (SCHEME_HASHTPx(obj)) { /* got here => printable */ Scheme_Hash_Table *t; Scheme_Object **keys, **vals, *val; @@ -591,7 +593,7 @@ static int check_cycles_fast(Scheme_Object *obj, PrintParams *pp, int *fast_chec } else cycle = 0; } else if (pp->print_hash_table - && SCHEME_HASHTP(obj)) { + && SCHEME_HASHTPx(obj)) { if (!((Scheme_Hash_Table *)obj)->count) cycle = 0; else @@ -702,7 +704,7 @@ static void setup_graph_table(Scheme_Object *obj, int for_write, Scheme_Hash_Tab setup_graph_table(((Scheme_Structure *)obj)->slots[i], for_write, ht, counter, pp); } } - } else if (pp && SCHEME_HASHTP(obj)) { /* got here => printable */ + } else if (pp && SCHEME_HASHTPx(obj)) { /* got here => printable */ Scheme_Hash_Table *t; Scheme_Object **keys, **vals, *val; int i; @@ -1831,7 +1833,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, } } else if ((compact || pp->print_hash_table) - && (SCHEME_HASHTP(obj) || SCHEME_HASHTRP(obj))) + && (SCHEME_HASHTPx(obj) || SCHEME_HASHTRP(obj))) { Scheme_Hash_Table *t; Scheme_Hash_Tree *tr; @@ -1918,6 +1920,12 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, closed = 1; } + else if (compact && SCHEME_HASHTP(obj)) + { + /* since previous case didn't catch this table, it has a 0x1 flag + and should be marshalled as #t */ + print_compact(pp, CPT_TRUE); + } else if (SAME_OBJ(obj, scheme_true)) { if (compact) diff --git a/src/mzscheme/src/read.c b/src/mzscheme/src/read.c index 1c65afc98a..6ea1585bbf 100644 --- a/src/mzscheme/src/read.c +++ b/src/mzscheme/src/read.c @@ -5322,6 +5322,7 @@ Scheme_Object *scheme_load_delayed_code(int _which, Scheme_Load_Delay *_delay_in unsigned char *st; Scheme_Object * volatile port; Scheme_Object * volatile v; + Scheme_Object * volatile v_exn; Scheme_Hash_Table ** volatile ht; mz_jmp_buf newbuf, * volatile savebuf; @@ -5417,12 +5418,16 @@ Scheme_Object *scheme_load_delayed_code(int _which, Scheme_Load_Delay *_delay_in /* Perform the read, catching escapes so we can clean up: */ savebuf = scheme_current_thread->error_buf; scheme_current_thread->error_buf = &newbuf; + scheme_current_thread->reading_delayed = scheme_true; if (scheme_setjmp(newbuf)) { v = NULL; + v_exn = scheme_current_thread->reading_delayed; } else { v = read_compact(rp, 0); + v_exn = NULL; } scheme_current_thread->error_buf = savebuf; + scheme_current_thread->reading_delayed = NULL; /* Clean up: */ @@ -5452,6 +5457,8 @@ Scheme_Object *scheme_load_delayed_code(int _which, Scheme_Load_Delay *_delay_in return v; } else { + if (v_exn && !scheme_current_thread->cjs.is_kill) + scheme_raise(v_exn); scheme_longjmp(*scheme_current_thread->error_buf, 1); return NULL; } diff --git a/src/mzscheme/src/schemef.h b/src/mzscheme/src/schemef.h index 0a52678a7e..6856587fc4 100644 --- a/src/mzscheme/src/schemef.h +++ b/src/mzscheme/src/schemef.h @@ -1071,6 +1071,7 @@ MZ_EXTERN long scheme_get_seconds(void); MZ_EXTERN long scheme_get_milliseconds(void); MZ_EXTERN double scheme_get_inexact_milliseconds(void); MZ_EXTERN long scheme_get_process_milliseconds(void); +MZ_EXTERN long scheme_get_thread_milliseconds(Scheme_Object *thrd); MZ_EXTERN char *scheme_banner(void); MZ_EXTERN char *scheme_version(void); diff --git a/src/mzscheme/src/schemex.h b/src/mzscheme/src/schemex.h index 6a3224ac99..dfaec8a86b 100644 --- a/src/mzscheme/src/schemex.h +++ b/src/mzscheme/src/schemex.h @@ -886,6 +886,7 @@ long (*scheme_get_seconds)(void); long (*scheme_get_milliseconds)(void); double (*scheme_get_inexact_milliseconds)(void); long (*scheme_get_process_milliseconds)(void); +long (*scheme_get_thread_milliseconds)(Scheme_Object *thrd); char *(*scheme_banner)(void); char *(*scheme_version)(void); int (*scheme_check_proc_arity)(const char *where, int a, diff --git a/src/mzscheme/src/schemex.inc b/src/mzscheme/src/schemex.inc index 0753e7a6eb..a1eb923619 100644 --- a/src/mzscheme/src/schemex.inc +++ b/src/mzscheme/src/schemex.inc @@ -620,6 +620,7 @@ scheme_extension_table->scheme_get_milliseconds = scheme_get_milliseconds; scheme_extension_table->scheme_get_inexact_milliseconds = scheme_get_inexact_milliseconds; scheme_extension_table->scheme_get_process_milliseconds = scheme_get_process_milliseconds; + scheme_extension_table->scheme_get_thread_milliseconds = scheme_get_thread_milliseconds; scheme_extension_table->scheme_banner = scheme_banner; scheme_extension_table->scheme_version = scheme_version; scheme_extension_table->scheme_check_proc_arity = scheme_check_proc_arity; diff --git a/src/mzscheme/src/schemexm.h b/src/mzscheme/src/schemexm.h index fec4281b78..bb7e3dd2eb 100644 --- a/src/mzscheme/src/schemexm.h +++ b/src/mzscheme/src/schemexm.h @@ -620,6 +620,7 @@ #define scheme_get_milliseconds (scheme_extension_table->scheme_get_milliseconds) #define scheme_get_inexact_milliseconds (scheme_extension_table->scheme_get_inexact_milliseconds) #define scheme_get_process_milliseconds (scheme_extension_table->scheme_get_process_milliseconds) +#define scheme_get_thread_milliseconds (scheme_extension_table->scheme_get_thread_milliseconds) #define scheme_banner (scheme_extension_table->scheme_banner) #define scheme_version (scheme_extension_table->scheme_version) #define scheme_check_proc_arity (scheme_extension_table->scheme_check_proc_arity) diff --git a/src/mzscheme/src/schminc.h b/src/mzscheme/src/schminc.h index 448a7dfaad..519ede6b74 100644 --- a/src/mzscheme/src/schminc.h +++ b/src/mzscheme/src/schminc.h @@ -13,7 +13,7 @@ #define USE_COMPILED_STARTUP 1 -#define EXPECTED_PRIM_COUNT 947 +#define EXPECTED_PRIM_COUNT 950 #ifdef MZSCHEME_SOMETHING_OMITTED # undef USE_COMPILED_STARTUP diff --git a/src/mzscheme/src/schnapp.inc b/src/mzscheme/src/schnapp.inc index 50baa5bd18..275cc877f4 100644 --- a/src/mzscheme/src/schnapp.inc +++ b/src/mzscheme/src/schnapp.inc @@ -3,6 +3,13 @@ scheme_do_eval()'s increment, because this might be the continuation of a tail call. */ +/* The arguments in argv are in the runstack. If computation can go + back into native code, those arguments should not live past the + native-code call. The native code clears/reuses arguments itself if + they are on the stack, but there's a problem if a tail buffer leads + to new pushes onto the run stack. We handle this with code marked + [TC-SFS]. */ + /* This code is written in such a way that xform can see that no GC cooperation is needed. */ @@ -26,8 +33,11 @@ static MZ_INLINE Scheme_Object *PRIM_APPLY_NAME_FAST(Scheme_Object *rator, v = f(argc, argv, (Scheme_Object *)prim); #if PRIM_CHECK_VALUE - if (v == SCHEME_TAIL_CALL_WAITING) + if (v == SCHEME_TAIL_CALL_WAITING) { + int i; + for (i = 0; i < argc; i++) { argv[i] = NULL; } /* [TC-SFS]; see above */ v = scheme_force_value_same_mark(v); + } #endif #if PRIM_CHECK_MULTI diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index ef64736e32..a37bd4b790 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -104,6 +104,13 @@ int scheme_num_types(void); # define SET_REQUIRED_TAG(e) /* empty */ #endif +#if MZ_USE_NOINLINE +# define MZ_DO_NOT_INLINE(decl) decl __attribute__ ((noinline)); +#else +# define MZ_DO_NOT_INLINE() +#endif + + void scheme_reset_finalizations(void); extern unsigned long scheme_get_current_os_thread_stack_base(void); @@ -743,6 +750,11 @@ Scheme_Object *scheme_stx_remove_extra_marks(Scheme_Object *o, Scheme_Object *re Scheme_Object *scheme_syntax_make_transfer_intro(int argc, Scheme_Object **argv); +void scheme_install_free_id_rename(Scheme_Object *id, + Scheme_Object *orig_id, + Scheme_Object *rename_rib, + Scheme_Object *phase); + #define mzMOD_RENAME_TOPLEVEL 0 #define mzMOD_RENAME_NORMAL 1 #define mzMOD_RENAME_MARKED 2 @@ -763,11 +775,11 @@ void scheme_seal_module_rename_set(Scheme_Object *rns, int level); #define STX_SEAL_ALL 2 Scheme_Object *scheme_make_module_rename(Scheme_Object *phase, int kind, Scheme_Hash_Table *mns); -void scheme_extend_module_rename(Scheme_Object *rn, Scheme_Object *modname, - 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* scheme_extend_module_rename(Scheme_Object *rn, Scheme_Object *modname, + 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); void scheme_extend_module_rename_with_shared(Scheme_Object *rn, Scheme_Object *modidx, struct Scheme_Module_Phase_Exports *pt, Scheme_Object *unmarshal_phase_index, @@ -797,12 +809,15 @@ 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(Scheme_Object **name, Scheme_Object *phase, +Scheme_Object *scheme_stx_module_name(int recur, + Scheme_Object **name, Scheme_Object *phase, Scheme_Object **nominal_modidx, Scheme_Object **nominal_name, Scheme_Object **mod_phase, Scheme_Object **src_phase_index, - Scheme_Object **nominal_src_phase); + Scheme_Object **nominal_src_phase, + Scheme_Object **lex_env, + int *_sealed); Scheme_Object *scheme_stx_moduleless_env(Scheme_Object *a); int scheme_stx_parallel_is_used(Scheme_Object *sym, Scheme_Object *stx); @@ -2111,7 +2126,7 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object Scheme_Env *exp_env, Scheme_Object *insp, Scheme_Compile_Expand_Info *rec, int drec, Scheme_Comp_Env *stx_env, Scheme_Comp_Env *rhs_env, - int *_pos); + int *_pos, Scheme_Object *rename_rib); int scheme_is_sub_env(Scheme_Comp_Env *stx_env, Scheme_Comp_Env *env); typedef struct SFS_Info { @@ -2507,6 +2522,12 @@ void scheme_unmarshal_wrap_set(Scheme_Unmarshal_Tables *ut, Scheme_Object *wraps_key, Scheme_Object *v); +int scheme_is_rename_transformer(Scheme_Object *o); +int scheme_is_binding_rename_transformer(Scheme_Object *o); +Scheme_Object *scheme_rename_transformer_id(Scheme_Object *o); +int scheme_is_set_transformer(Scheme_Object *o); +Scheme_Object *scheme_set_transformer_proc(Scheme_Object *o); + /*========================================================================*/ /* namespaces and modules */ /*========================================================================*/ diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index baece58a99..3b6a3749fc 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -13,11 +13,11 @@ consistently.) */ -#define MZSCHEME_VERSION "4.1.4.3" +#define MZSCHEME_VERSION "4.1.5.3" #define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_Y 1 -#define MZSCHEME_VERSION_Z 4 +#define MZSCHEME_VERSION_Z 5 #define MZSCHEME_VERSION_W 3 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) diff --git a/src/mzscheme/src/sema.c b/src/mzscheme/src/sema.c index 4980063a15..0e927e49a8 100644 --- a/src/mzscheme/src/sema.c +++ b/src/mzscheme/src/sema.c @@ -387,6 +387,7 @@ static int out_of_line(Scheme_Object *a) } static void get_into_line(Scheme_Sema *sema, Scheme_Channel_Syncer *w) + /* Can be called multiple times. */ { Scheme_Channel_Syncer *last, *first; @@ -430,6 +431,8 @@ static void get_outof_line(Scheme_Sema *sema, Scheme_Channel_Syncer *w) { Scheme_Channel_Syncer *last, *first; + if (!w->in_line) + return; w->in_line = 0; if (SAME_TYPE(SCHEME_TYPE(sema), scheme_never_evt_type)) { diff --git a/src/mzscheme/src/setjmpup.c b/src/mzscheme/src/setjmpup.c index 8aad99bf14..57e3dca67b 100644 --- a/src/mzscheme/src/setjmpup.c +++ b/src/mzscheme/src/setjmpup.c @@ -325,7 +325,9 @@ void MZ_NO_INLINE scheme_copy_stack(Scheme_Jumpup_Buf *b, void *base, void *star size); } -static void uncopy_stack(int ok, Scheme_Jumpup_Buf *b, long *prev) +MZ_DO_NOT_INLINE(void scheme_uncopy_stack(int ok, Scheme_Jumpup_Buf *b, long *prev)); + +void scheme_uncopy_stack(int ok, Scheme_Jumpup_Buf *b, long *prev) { GC_CAN_IGNORE Scheme_Jumpup_Buf *c; long top_delta = 0, bottom_delta = 0, size; @@ -337,7 +339,7 @@ static void uncopy_stack(int ok, Scheme_Jumpup_Buf *b, long *prev) z = (unsigned long)&junk[0]; - uncopy_stack(STK_COMP(z, DEEPPOS(b)), b, junk); + scheme_uncopy_stack(STK_COMP(z, DEEPPOS(b)), b, junk); } /* Vague attempt to prevent the compiler from optimizing away `prev': */ @@ -619,7 +621,7 @@ void scheme_longjmpup(Scheme_Jumpup_Buf *b) scheme_flush_stack_cache(); #endif - uncopy_stack(STK_COMP((unsigned long)&z, DEEPPOS(b)), b, junk); + scheme_uncopy_stack(STK_COMP((unsigned long)&z, DEEPPOS(b)), b, junk); } void scheme_init_jmpup_buf(Scheme_Jumpup_Buf *b) diff --git a/src/mzscheme/src/struct.c b/src/mzscheme/src/struct.c index 8c0c3d0753..d3f23a65ab 100644 --- a/src/mzscheme/src/struct.c +++ b/src/mzscheme/src/struct.c @@ -70,6 +70,8 @@ static Scheme_Object *check_equal_property_value_ok(int argc, Scheme_Object *arg static Scheme_Object *check_write_property_value_ok(int argc, Scheme_Object *argv[]); static Scheme_Object *check_input_port_property_value_ok(int argc, Scheme_Object *argv[]); static Scheme_Object *check_output_port_property_value_ok(int argc, Scheme_Object *argv[]); +static Scheme_Object *check_rename_transformer_property_value_ok(int argc, Scheme_Object *argv[]); +static Scheme_Object *check_set_transformer_property_value_ok(int argc, Scheme_Object *argv[]); static Scheme_Object *make_struct_type(int argc, Scheme_Object *argv[]); @@ -134,6 +136,10 @@ static Scheme_Object *exn_source_get(int argc, Scheme_Object **argv); static Scheme_Object *procedure_extract_target(int argc, Scheme_Object **argv); +static Scheme_Object *rename_transformer_property; +static Scheme_Object *set_transformer_property; +static Scheme_Object *not_free_id_symbol; + #ifdef MZ_PRECISE_GC static void register_traversers(void); #endif @@ -178,6 +184,7 @@ scheme_init_struct (Scheme_Env *env) Scheme_Object **loc_values, *loc_et; int loc_count; int i; + Scheme_Object *guard; static const char *arity_fields[1] = { "value" }; #ifdef TIME_SYNTAX @@ -253,7 +260,7 @@ scheme_init_struct (Scheme_Env *env) REGISTER_SO(write_property); { - Scheme_Object *guard, *a[2], *pred, *access; + Scheme_Object *a[2], *pred, *access; guard = scheme_make_prim_w_arity(check_write_property_value_ok, "guard-for-prop:custom-write", 2, 2); @@ -271,7 +278,6 @@ scheme_init_struct (Scheme_Env *env) REGISTER_SO(evt_property); { - Scheme_Object *guard; guard = scheme_make_prim_w_arity(check_evt_property_value_ok, "guard-for-prop:evt", 2, 2); @@ -292,7 +298,6 @@ scheme_init_struct (Scheme_Env *env) } { - Scheme_Object *guard; guard = scheme_make_prim_w_arity(check_equal_property_value_ok, "guard-for-prop:equal+hash", 2, 2); @@ -303,7 +308,6 @@ scheme_init_struct (Scheme_Env *env) } { - Scheme_Object *guard; REGISTER_SO(scheme_input_port_property); REGISTER_SO(scheme_output_port_property); @@ -323,6 +327,33 @@ scheme_init_struct (Scheme_Env *env) scheme_add_global_constant("prop:output-port", scheme_output_port_property, env); } + { + REGISTER_SO(rename_transformer_property); + + guard = scheme_make_prim_w_arity(check_rename_transformer_property_value_ok, + "guard-for-prop:rename-transformer", + 2, 2); + rename_transformer_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("rename-transformer"), + guard); + + scheme_add_global_constant("prop:rename-transformer", rename_transformer_property, env); + } + + { + REGISTER_SO(set_transformer_property); + + guard = scheme_make_prim_w_arity(check_set_transformer_property_value_ok, + "guard-for-prop:set!-transformer", + 2, 2); + set_transformer_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("set!-transformer"), + guard); + + scheme_add_global_constant("prop:set!-transformer", set_transformer_property, env); + } + + REGISTER_SO(not_free_id_symbol); + not_free_id_symbol = scheme_intern_symbol("not-free-identifier=?"); + REGISTER_SO(scheme_recur_symbol); REGISTER_SO(scheme_display_symbol); REGISTER_SO(scheme_write_special_symbol); @@ -552,7 +583,6 @@ scheme_init_struct (Scheme_Env *env) REGISTER_SO(scheme_source_property); { - Scheme_Object *guard; guard = scheme_make_prim_w_arity(check_exn_source_property_value_ok, "guard-for-prop:exn:srclocs", 2, 2); @@ -1073,25 +1103,22 @@ static int is_evt_struct(Scheme_Object *o) /* port structs */ /*========================================================================*/ -static Scheme_Object *check_port_property_value_ok(const char *name, int input, int argc, Scheme_Object *argv[]) -/* This is the guard for prop:input-port and prop:output-port */ +typedef int (*Check_Val_Proc)(Scheme_Object *); + +static Scheme_Object *check_indirect_property_value_ok(const char *name, Check_Val_Proc ck, const char *complain, + int argc, Scheme_Object *argv[]) { Scheme_Object *v, *l, *acc; int pos, num_islots; v = argv[0]; - - if ((input && SCHEME_INPUT_PORTP(v)) - || (!input && SCHEME_OUTPUT_PORTP(v))) + + if (ck(v)) return v; if (!((SCHEME_INTP(v) && (SCHEME_INT_VAL(v) >= 0)) || (SCHEME_BIGNUMP(v) && SCHEME_BIGPOS(v)))) - scheme_arg_mismatch(name, - (input - ? "property value is not an input port or exact non-negative integer: " - : "property value is not an output port or exact non-negative integer: "), - v); + scheme_arg_mismatch(name, complain, v); l = argv[1]; l = SCHEME_CDR(l); @@ -1131,6 +1158,20 @@ static Scheme_Object *check_port_property_value_ok(const char *name, int input, return v; } +static int is_input_port(Scheme_Object *v) { return SCHEME_INPUT_PORTP(v); } +static int is_output_port(Scheme_Object *v) { return SCHEME_OUTPUT_PORTP(v); } + +static Scheme_Object *check_port_property_value_ok(const char *name, int input, int argc, Scheme_Object *argv[]) +/* This is the guard for prop:input-port and prop:output-port */ +{ + return check_indirect_property_value_ok(name, + input ? is_input_port : is_output_port, + (input + ? "property value is not an input port or exact non-negative integer: " + : "property value is not an output port or exact non-negative integer: "), + argc, argv); +} + static Scheme_Object *check_input_port_property_value_ok(int argc, Scheme_Object *argv[]) { return check_port_property_value_ok("guard-for-prop:input-port", 1, argc, argv); @@ -1207,6 +1248,107 @@ Scheme_Object *scheme_is_writable_struct(Scheme_Object *s) return scheme_struct_type_property_ref(write_property, s); } +/*========================================================================*/ +/* rename and set! transformer properties */ +/*========================================================================*/ + +int scheme_is_rename_transformer(Scheme_Object *o) +{ + if (SAME_TYPE(SCHEME_TYPE(o), scheme_id_macro_type)) + return 1; + if (SCHEME_STRUCTP(o) + && scheme_struct_type_property_ref(rename_transformer_property, o)) + return 1; + return 0; +} + +int scheme_is_binding_rename_transformer(Scheme_Object *o) +{ + if (scheme_is_rename_transformer(o)) { + o = scheme_rename_transformer_id(o); + o = scheme_stx_property(o, not_free_id_symbol, NULL); + if (o && SCHEME_TRUEP(o)) + return 0; + return 1; + } + return 0; +} + +static int is_stx_id(Scheme_Object *o) { return (SCHEME_STXP(o) && SCHEME_SYMBOLP(SCHEME_STX_VAL(o))); } + +Scheme_Object *scheme_rename_transformer_id(Scheme_Object *o) +{ + if (SAME_TYPE(SCHEME_TYPE(o), scheme_id_macro_type)) + return SCHEME_PTR1_VAL(o); + if (SCHEME_STRUCTP(o)) { + Scheme_Object *v; + v = scheme_struct_type_property_ref(rename_transformer_property, o); + if (SCHEME_BOXP(v)) v = SCHEME_BOX_VAL(v); + if (SCHEME_INTP(v)) { + v = ((Scheme_Structure *)o)->slots[SCHEME_INT_VAL(v)]; + if (!is_stx_id(v)) { + v = scheme_datum_to_syntax(scheme_intern_symbol("?"), scheme_false, scheme_false, 0, 0); + } + } + return v; + } + return NULL; +} + +static Scheme_Object *check_rename_transformer_property_value_ok(int argc, Scheme_Object *argv[]) +{ + return check_indirect_property_value_ok("guard-for-prop:rename-transformer", + is_stx_id, + "property value is not an identifier or exact non-negative integer, optionaly boxed: ", + argc, argv); +} + +int scheme_is_set_transformer(Scheme_Object *o) +{ + if (SAME_TYPE(SCHEME_TYPE(o), scheme_set_macro_type)) + return 1; + if (SCHEME_STRUCTP(o) + && scheme_struct_type_property_ref(set_transformer_property, o)) + return 1; + return 0; +} + +static int is_proc_1(Scheme_Object *o) { return (SCHEME_PROCP(o) && scheme_check_proc_arity(NULL, 1, -1, 0, &o)); } + +Scheme_Object *signal_bad_syntax(int argc, Scheme_Object **argv) +{ + scheme_wrong_syntax(NULL, NULL, argv[0], "bad syntax"); + return NULL; +} + +Scheme_Object *scheme_set_transformer_proc(Scheme_Object *o) +{ + if (SAME_TYPE(SCHEME_TYPE(o), scheme_set_macro_type)) + return SCHEME_PTR_VAL(o); + if (SCHEME_STRUCTP(o)) { + Scheme_Object *v; + v = scheme_struct_type_property_ref(set_transformer_property, o); + if (SCHEME_INTP(v)) { + v = ((Scheme_Structure *)o)->slots[SCHEME_INT_VAL(v)]; + if (!is_proc_1(v)) { + v = scheme_make_prim_w_arity(signal_bad_syntax, + "bad-syntax-set!-transformer", + 1, 1); + } + } + return v; + } + return NULL; +} + +static Scheme_Object *check_set_transformer_property_value_ok(int argc, Scheme_Object *argv[]) +{ + return check_indirect_property_value_ok("guard-for-prop:set!-transformer", + is_proc_1, + "property value is not an procedure (arity 1) or exact non-negative integer: ", + argc, argv); +} + /*========================================================================*/ /* struct ops */ /*========================================================================*/ diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index b8a6e75373..2792830328 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -76,11 +76,12 @@ static Scheme_Object *share_symbol; /* uninterned! */ static Scheme_Object *origin_symbol; static Scheme_Object *lexical_symbol; static Scheme_Object *protected_symbol; +static Scheme_Object *nominal_id_symbol; -static Scheme_Object *nominal_ipair_cache; +static THREAD_LOCAL Scheme_Object *nominal_ipair_cache; -static Scheme_Object *mark_id = scheme_make_integer(0); -static Scheme_Object *current_rib_timestamp = scheme_make_integer(0); +static THREAD_LOCAL Scheme_Object *mark_id = scheme_make_integer(0); +static THREAD_LOCAL Scheme_Object *current_rib_timestamp = scheme_make_integer(0); static Scheme_Stx_Srcloc *empty_srcloc; @@ -88,11 +89,12 @@ static Scheme_Object *empty_simplified; static Scheme_Hash_Table *empty_hash_table; -static Scheme_Object *last_phase_shift; +static THREAD_LOCAL Scheme_Object *last_phase_shift; -/* caches */ -static THREAD_LOCAL Scheme_Hash_Table *id_marks_ht; -static THREAD_LOCAL Scheme_Hash_Table *than_id_marks_ht; +static THREAD_LOCAL Scheme_Object *unsealed_dependencies; + +static THREAD_LOCAL Scheme_Hash_Table *id_marks_ht; /* a cache */ +static THREAD_LOCAL Scheme_Hash_Table *than_id_marks_ht; /* a cache */ static Scheme_Object *no_nested_inactive_certs; @@ -149,6 +151,11 @@ typedef struct Module_Renames { set to a gensym created for the binding */ Scheme_Object *unmarshal_info; /* stores some renamings as infomation needed to consult imported modules and restore renames from their exports */ + Scheme_Hash_Table *free_id_renames; /* like `ht', but only for free-id=? checking, + and targets can also include: + id => resolve id (but cache if possible; never appears after simplifying) + (box (cons sym #f)) => top-level binding + (box (cons sym sym)) => lexical binding */ } Module_Renames; typedef struct Module_Renames_Set { @@ -208,6 +215,8 @@ static Module_Renames *krn; #define SCHEME_RENAMESP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_rename_table_type)) #define SCHEME_RENAMES_SETP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_rename_table_set_type)) +#define SCHEME_MODIDXP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_module_index_type)) + /* Wraps: A wrap is a list of wrap-elems and wrap-chunks. A wrap-chunk is a @@ -220,13 +229,23 @@ static Module_Renames *krn; - A wrap-elem <-num> is a certificate-only mark (doesn't conttribute to id equivalence) - - A wrap-elem (vector ... ...) is a lexical rename - env (sym var var-resolved + - A wrap-elem (vector ... ...) is a lexical rename + env (sym var : ->pos) void => not yet computed - or #f sym => mark check done, - var-resolved is answer to replace #f - - A wrap-elem (vector ... ...) is also a lexical rename - var resolved + or #f sym => var-resolved is answer to replace #f + for nozero skipped ribs + (rlistof (rcons skipped sym)) => generalization of sym + (mcons var-resolved next) => depends on unsealed rib, + will be cleared when rib set + or: + (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 where the variables have already been resolved and filtered (no mark or lexical-env comparison needed with the remaining wraps) @@ -526,11 +545,13 @@ void scheme_init_stx(Scheme_Env *env) REGISTER_SO(origin_symbol); REGISTER_SO(lexical_symbol); REGISTER_SO(protected_symbol); + REGISTER_SO(nominal_id_symbol); source_symbol = scheme_make_symbol("source"); /* not interned! */ share_symbol = scheme_make_symbol("share"); /* not interned! */ origin_symbol = scheme_intern_symbol("origin"); lexical_symbol = scheme_intern_symbol("lexical"); protected_symbol = scheme_intern_symbol("protected"); + nominal_id_symbol = scheme_intern_symbol("nominal-id"); REGISTER_SO(mark_id); @@ -560,6 +581,8 @@ void scheme_init_stx(Scheme_Env *env) REGISTER_SO(no_nested_inactive_certs); no_nested_inactive_certs = scheme_make_raw_pair(NULL, NULL); SCHEME_SET_IMMUTABLE(no_nested_inactive_certs); + + REGISTER_SO(unsealed_dependencies); } /*========================================================================*/ @@ -807,7 +830,7 @@ static int maybe_add_chain_cache(Scheme_Stx *stx) if (SCHEME_VECTORP(p)) { skipable++; } else if (SCHEME_NUMBERP(p) || SCHEME_SYMBOLP(p)) { - /* ok to skip, but don't count toward needing a cache */ + /* ok to skip, but don<'t count toward needing a cache */ } else if (SCHEME_HASHTP(p)) { /* Hack: we store the depth of the table in the chain in the `size' fields, at least until the table is initialized: */ @@ -1001,6 +1024,8 @@ Scheme_Object *scheme_add_remove_mark(Scheme_Object *o, Scheme_Object *m) /******************** lexical renames ********************/ +#define RENAME_HT_THRESHOLD 15 + Scheme_Object *scheme_make_rename(Scheme_Object *newname, int c) { Scheme_Object *v; @@ -1008,7 +1033,7 @@ Scheme_Object *scheme_make_rename(Scheme_Object *newname, int c) v = scheme_make_vector((2 * c) + 2, NULL); SCHEME_VEC_ELS(v)[0] = newname; - if (c > 15) { + if (c > RENAME_HT_THRESHOLD) { Scheme_Hash_Table *ht; ht = scheme_make_hash_table(SCHEME_hash_ptr); SCHEME_VEC_ELS(v)[1] = (Scheme_Object *)ht; @@ -1022,6 +1047,21 @@ Scheme_Object *scheme_make_rename(Scheme_Object *newname, int c) return v; } +static void maybe_install_rename_hash_table(Scheme_Object *v) +{ + if (SCHEME_VEC_SIZE(v) > ((2 * RENAME_HT_THRESHOLD) + 2)) { + Scheme_Hash_Table *ht; + int i; + + ht = scheme_make_hash_table(SCHEME_hash_ptr); + MZ_OPT_HASH_KEY(&(ht->iso)) |= 0x1; + for (i = (SCHEME_VEC_SIZE(v) - 2) >> 1; i--; ) { + scheme_hash_set(ht, SCHEME_VEC_ELS(v)[i + 2], scheme_make_integer(i)); + } + SCHEME_VEC_ELS(v)[1] = (Scheme_Object *)ht; + } +} + void scheme_set_rename(Scheme_Object *rnm, int pos, Scheme_Object *oldname) { /* Every added name must be symbolicly distinct! */ @@ -1059,6 +1099,7 @@ Scheme_Object *scheme_make_rename_rib() void scheme_add_rib_rename(Scheme_Object *ro, Scheme_Object *rename) { Scheme_Lexical_Rib *rib, *naya; + Scheme_Object *next; naya = MALLOC_ONE_TAGGED(Scheme_Lexical_Rib); naya->so.type = scheme_lexical_rib_type; @@ -1070,6 +1111,13 @@ void scheme_add_rib_rename(Scheme_Object *ro, Scheme_Object *rename) naya->timestamp = rib->timestamp; naya->sealed = rib->sealed; + + while (unsealed_dependencies) { + next = SCHEME_CDR(unsealed_dependencies); + SCHEME_CAR(unsealed_dependencies) = NULL; + SCHEME_CDR(unsealed_dependencies) = NULL; + unsealed_dependencies = next; + } } void scheme_drop_first_rib_rename(Scheme_Object *ro) @@ -1318,21 +1366,24 @@ static Scheme_Object *phase_to_index(Scheme_Object *phase) return phase; } -void scheme_extend_module_rename(Scheme_Object *mrn, - Scheme_Object *modname, /* actual source module */ - Scheme_Object *localname, /* name in local context */ - Scheme_Object *exname, /* name in definition context */ - Scheme_Object *nominal_mod, /* nominal source module */ - Scheme_Object *nominal_ex, /* nominal import before local renaming */ - int mod_phase, /* phase of source defn */ - Scheme_Object *src_phase_index, /* nominal import phase */ - Scheme_Object *nom_phase, /* nominal export phase */ - int unmarshal_drop) /* 1 => can be reconstructed from unmarshal info */ +Scheme_Object *scheme_extend_module_rename(Scheme_Object *mrn, + Scheme_Object *modname, /* actual source module */ + Scheme_Object *localname, /* name in local context */ + Scheme_Object *exname, /* name in definition context */ + Scheme_Object *nominal_mod, /* nominal source module */ + Scheme_Object *nominal_ex, /* nominal import before local renaming */ + int mod_phase, /* phase of source defn */ + Scheme_Object *src_phase_index, /* nominal import phase */ + Scheme_Object *nom_phase, /* nominal export phase */ + int mode) /* 1 => can be reconstructed from unmarshal info + 2 => free-id=? renaming + 3 => return info */ { Scheme_Object *elem; Scheme_Object *phase_index; - check_not_sealed((Module_Renames *)mrn); + if (mode != 3) + check_not_sealed((Module_Renames *)mrn); phase_index = phase_to_index(((Module_Renames *)mrn)->phase); if (!src_phase_index) @@ -1379,15 +1430,21 @@ void scheme_extend_module_rename(Scheme_Object *mrn, elem = CONS(modname, elem); } - if (unmarshal_drop) { + if (mode == 1) { if (!((Module_Renames *)mrn)->nomarshal_ht) { Scheme_Hash_Table *ht; ht = scheme_make_hash_table(SCHEME_hash_ptr); ((Module_Renames *)mrn)->nomarshal_ht = ht; } scheme_hash_set(((Module_Renames *)mrn)->nomarshal_ht, localname, elem); + } else if (mode == 2) { + scheme_hash_set(((Module_Renames *)mrn)->free_id_renames, localname, elem); + } else if (mode == 3) { + return elem; } else scheme_hash_set(((Module_Renames *)mrn)->ht, localname, elem); + + return NULL; } void scheme_extend_module_rename_with_shared(Scheme_Object *rn, Scheme_Object *modidx, @@ -1599,6 +1656,8 @@ void scheme_remove_module_rename(Scheme_Object *mrn, scheme_hash_set(((Module_Renames *)mrn)->ht, localname, NULL); if (((Module_Renames *)mrn)->nomarshal_ht) scheme_hash_set(((Module_Renames *)mrn)->nomarshal_ht, localname, NULL); + if (((Module_Renames *)mrn)->free_id_renames) + scheme_hash_set(((Module_Renames *)mrn)->free_id_renames, localname, NULL); } void scheme_list_module_rename(Scheme_Object *set, Scheme_Hash_Table *ht) @@ -1871,6 +1930,151 @@ Scheme_Object *scheme_add_rename_rib(Scheme_Object *o, Scheme_Object *rib) return scheme_add_rename(o, rib); } +static Scheme_Object *extract_module_free_id_binding(Scheme_Object *mrn, + Scheme_Object *id, + Scheme_Object *orig_id, + int *_sealed) +{ + Scheme_Object *result; + Scheme_Object *modname; + Scheme_Object *nominal_modidx; + Scheme_Object *nominal_name, *nom2; + Scheme_Object *mod_phase; + Scheme_Object *src_phase_index; + Scheme_Object *nominal_src_phase; + Scheme_Object *lex_env; + + nom2 = scheme_stx_property(orig_id, nominal_id_symbol, NULL); + + modname = scheme_stx_module_name(1, + &orig_id, ((Module_Renames *)mrn)->phase, &nominal_modidx, + &nominal_name, + &mod_phase, + &src_phase_index, + &nominal_src_phase, + &lex_env, + _sealed); + + if (SCHEME_SYMBOLP(nom2)) + nominal_name = nom2; + + if (!modname) + result = scheme_box(CONS(SCHEME_STX_VAL(orig_id), scheme_false)); + else if (SAME_OBJ(modname, scheme_undefined)) + result = scheme_box(CONS(SCHEME_STX_VAL(orig_id), lex_env)); + else + result = scheme_extend_module_rename(mrn, + modname, + id, /* name in local context */ + orig_id, /* name in definition context */ + nominal_modidx, /* nominal source module */ + nominal_name, /* nominal import before local renaming */ + SCHEME_INT_VAL(mod_phase), /* phase of source defn */ + src_phase_index, /* nominal import phase */ + nominal_src_phase, /* nominal export phase */ + 3); + + if (*_sealed) { + /* cache the result */ + scheme_hash_set(((Module_Renames *)mrn)->free_id_renames, id, result); + } + + return result; +} + +void scheme_install_free_id_rename(Scheme_Object *id, + Scheme_Object *orig_id, + Scheme_Object *rename_rib, + Scheme_Object *phase) +{ + Scheme_Object *v = NULL, *env, *r_id; + Scheme_Lexical_Rib *rib = NULL; + + if (rename_rib && (SCHEME_RENAMESP(rename_rib) || SCHEME_RENAMES_SETP(rename_rib))) { + /* Install a Module_Rename-level free-id=? rename, instead of at + the level of a lexical-rename. In this case, id is a symbol instead + of an identifier. */ + Module_Renames *rn; + + if (SCHEME_RENAMES_SETP(rename_rib)) + rename_rib = scheme_get_module_rename_from_set(rename_rib, phase, 1); + rn = (Module_Renames *)rename_rib; + + if (!rn->free_id_renames) { + Scheme_Hash_Table *ht; + ht = scheme_make_hash_table(SCHEME_hash_ptr); + rn->free_id_renames = ht; + } + + scheme_hash_set(rn->free_id_renames, id, orig_id); + + return; + } + + env = scheme_stx_moduleless_env(id); + + if (rename_rib) { + rib = (Scheme_Lexical_Rib *)rename_rib; + } else { + WRAP_POS wl; + + WRAP_POS_INIT(wl, ((Scheme_Stx *)id)->wraps); + while (!WRAP_POS_END_P(wl)) { + v = WRAP_POS_FIRST(wl); + if (SCHEME_VECTORP(v) && SAME_OBJ(SCHEME_VEC_ELS(v)[0], env)) { + break; + } if (SCHEME_RIBP(v)) { + rib = (Scheme_Lexical_Rib *)v; + while (rib) { + if (rib->rename) { + v = rib->rename; + if (SCHEME_VECTORP(v) && SAME_OBJ(SCHEME_VEC_ELS(v)[0], env)) + break; + v = NULL; + } + rib = rib->next; + } + } else + v = NULL; + WRAP_POS_INC(wl); + } + } + + while (v || rib) { + if (!v) { + while (rib) { + if (rib->rename) { + v = rib->rename; + if (SCHEME_VECTORP(v) && SAME_OBJ(SCHEME_VEC_ELS(v)[0], env)) + break; + v = NULL; + } + rib = rib->next; + } + } + + if (v) { + int i, sz; + + sz = SCHEME_RENAME_LEN(v); + for (i = 0; i < sz; i++) { + r_id = SCHEME_VEC_ELS(v)[i+2]; + if (SAME_OBJ(SCHEME_STX_SYM(r_id), SCHEME_STX_VAL(id))) { + /* Install rename: */ + env = SCHEME_VEC_ELS(v)[i+sz+2]; + if (SCHEME_PAIRP(env)) env = SCHEME_CAR(env); + env = CONS(env, CONS(orig_id, phase)); + SCHEME_VEC_ELS(v)[i+sz+2] = env; + return; + } + } + } + + v = NULL; + if (rib) rib = rib->next; + } +} + Scheme_Object *scheme_stx_phase_shift_as_rename(long shift, Scheme_Object *old_midx, Scheme_Object *new_midx, Scheme_Hash_Table *export_registry) { @@ -3163,8 +3367,8 @@ static Scheme_Object *check_floating_id(Scheme_Object *stx) #define EXPLAIN_RESOLVE 0 #if EXPLAIN_RESOLVE -static int explain_resolves = 1; -# define EXPLAIN(x) if (explain_resolves) { x; } +int scheme_explain_resolves = 0; +# define EXPLAIN(x) if (scheme_explain_resolves) { x; } #else # define EXPLAIN(x) /* empty */ #endif @@ -3425,7 +3629,8 @@ static void add_all_marks(Scheme_Object *wraps, Scheme_Hash_Table *marks) } } -static int check_matching_marks(Scheme_Object *p, Scheme_Object *orig_id, Scheme_Object **marks_cache, int depth) +static int check_matching_marks(Scheme_Object *p, Scheme_Object *orig_id, Scheme_Object **marks_cache, int depth, + int *_skipped) { int l1, l2; Scheme_Object *m1, *m2; @@ -3434,6 +3639,7 @@ static int check_matching_marks(Scheme_Object *p, Scheme_Object *orig_id, Scheme p = SCHEME_CDR(p); /* skip phase_export */ if (SCHEME_PAIRP(p)) { /* has marks */ + int skip = 0; EXPLAIN(fprintf(stderr, "%d has marks\n", depth)); @@ -3454,25 +3660,30 @@ static int check_matching_marks(Scheme_Object *p, Scheme_Object *orig_id, Scheme while (l2 > l1) { m2 = SCHEME_CDR(m2); l2--; + skip++; } - if (scheme_equal(m1, m2)) + if (scheme_equal(m1, m2)) { + if (_skipped ) *_skipped = skip; return l1; /* matches */ - else + } else return -1; /* no match */ - } else + } else { + if (_skipped) *_skipped = -1; return 0; /* match empty mark set */ + } } static Scheme_Object *search_shared_pes(Scheme_Object *shared_pes, Scheme_Object *glob_id, Scheme_Object *orig_id, Scheme_Object **get_names, int get_orig_name, - int depth) + int depth, + int *_skipped) { 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; + int i, phase, best_match_len = -1, skip; Scheme_Object *marks_cache = NULL; for (pr = shared_pes; !SCHEME_NULLP(pr); pr = SCHEME_CDR(pr)) { @@ -3495,10 +3706,11 @@ static Scheme_Object *search_shared_pes(Scheme_Object *shared_pes, /* Found it, maybe. Check marks. */ int mark_len; EXPLAIN(fprintf(stderr, "%d found %p\n", depth, pos)); - mark_len = check_matching_marks(SCHEME_CAR(pr), orig_id, &marks_cache, depth); + 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; idx = SCHEME_CAR(SCHEME_CAR(pr)); @@ -3548,11 +3760,12 @@ static Scheme_Object *search_shared_pes(Scheme_Object *shared_pes, kpr = scheme_hash_get(krn->ht, glob_id); if (kpr) { /* Found it, maybe. Check marks. */ - int mark_len; - mark_len = check_matching_marks(SCHEME_CAR(pr), orig_id, &marks_cache, depth); + 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; @@ -3614,10 +3827,109 @@ static int in_skip_set(Scheme_Object *timestamp, Scheme_Object *skip_ribs) static Scheme_Object *add_skip_set(Scheme_Object *timestamp, Scheme_Object *skip_ribs) { - return scheme_make_raw_pair(timestamp, skip_ribs); + if (in_skip_set(timestamp, skip_ribs)) + return skip_ribs; + else + return scheme_make_raw_pair(timestamp, skip_ribs); } -#define QUICK_STACK_SIZE 8 +XFORM_NONGCING static int same_skipped_ribs(Scheme_Object *a, Scheme_Object *b) +{ + while (a) { + if (!b) return 0; + if (!SAME_OBJ(SCHEME_CAR(a), SCHEME_CAR(b))) + return 0; + a = SCHEME_CDR(a); + b = SCHEME_CDR(b); + } + return !b; +} + +XFORM_NONGCING static Scheme_Object *filter_cached_env(Scheme_Object *other_env, Scheme_Object *skip_ribs) +{ + Scheme_Object *p; + + if (SCHEME_PAIRP(other_env)) { + /* paired with free-id=? rename */ + other_env = SCHEME_CAR(other_env); + } + + if (SCHEME_MPAIRP(other_env)) { + other_env = SCHEME_CAR(other_env); + if (!other_env) + return scheme_void; + } + + if (SCHEME_RPAIRP(other_env)) { + while (other_env) { + p = SCHEME_CAR(other_env); + if (same_skipped_ribs(SCHEME_CAR(p), skip_ribs)) + return SCHEME_CDR(p); + other_env = SCHEME_CDR(other_env); + } + return scheme_void; + } else if (!skip_ribs) + return other_env; + else + return scheme_void; +} + +static Scheme_Object *extend_cached_env(Scheme_Object *orig, Scheme_Object *other_env, Scheme_Object *skip_ribs, + int depends_on_unsealed_rib) +{ + Scheme_Object *in_mpair = NULL; + Scheme_Object *free_id_rename = NULL; + + if (SCHEME_PAIRP(orig)) { + free_id_rename = SCHEME_CDR(orig); + orig = SCHEME_CAR(orig); + } + + if (SCHEME_MPAIRP(orig)) { + in_mpair = orig; + orig = SCHEME_CAR(orig); + if (!depends_on_unsealed_rib && !orig) { + /* no longer depends on unsealed rib: */ + in_mpair = NULL; + orig = scheme_void; + } else { + /* (some) still depends on unsealed rib: */ + if (!orig) { + /* re-register in list of dependencies */ + SCHEME_CDR(in_mpair) = unsealed_dependencies; + unsealed_dependencies = in_mpair; + orig = scheme_void; + } + } + } else if (depends_on_unsealed_rib) { + /* register dependency: */ + in_mpair = scheme_make_mutable_pair(NULL, unsealed_dependencies); + unsealed_dependencies = in_mpair; + } + + if (SCHEME_VOIDP(orig) && !skip_ribs) { + orig = other_env; + } else { + if (!SCHEME_RPAIRP(orig)) + orig = scheme_make_raw_pair(scheme_make_raw_pair(NULL, orig), NULL); + + orig = scheme_make_raw_pair(scheme_make_raw_pair(skip_ribs, other_env), orig); + } + + if (in_mpair) { + SCHEME_CAR(in_mpair) = orig; + orig = in_mpair; + } + + if (free_id_rename) { + orig = CONS(orig, free_id_rename); + } + + return orig; +} + +/* This needs to be a multiple of 3: */ +#define QUICK_STACK_SIZE 12 /* Although resolve_env may call itself recursively, the recursion depth is bounded (by the fact that modules can't be nested, @@ -3627,15 +3939,17 @@ 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 *_depends_on_unsealed_rib, int depth, int get_free_id_info) /* 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. - If lexically bound, result is env id, and a get_names[0] is set to scheme_undefined. - If neither, result is #f and get_names[0] is either unchanged or NULL. */ + 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] + is set if a free-id=? rename provides a different name. */ { WRAP_POS wraps; Scheme_Object *o_rename_stack = scheme_null, *recur_skip_ribs = skip_ribs; @@ -3649,7 +3963,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, Scheme_Object *bdg = NULL, *floating = NULL; Scheme_Hash_Table *export_registry = NULL; int mresult_skipped = -1; - int depends_on_unsealed_rib = 0; + int depends_on_unsealed_rib = 0, mresult_depends_unsealed = 0; EXPLAIN(fprintf(stderr, "%d Resolving %s [skips: %s]:\n", depth, SCHEME_SYM_VAL(SCHEME_STX_VAL(a)), scheme_write_to_string(skip_ribs ? skip_ribs : scheme_false, NULL))); @@ -3663,18 +3977,21 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, while (1) { if (WRAP_POS_END_P(wraps)) { /* See rename case for info on rename_stack: */ - Scheme_Object *result, *key; + Scheme_Object *result, *result_free_rename, *key; int did_lexical = 0; EXPLAIN(fprintf(stderr, "%d Rename...\n", depth)); result = scheme_false; + result_free_rename = scheme_false; while (!SCHEME_NULLP(o_rename_stack)) { key = SCHEME_CAAR(o_rename_stack); if (SAME_OBJ(key, result)) { EXPLAIN(fprintf(stderr, "%d Match %s\n", depth, scheme_write_to_string(key, 0))); did_lexical = 1; result = SCHEME_CDR(SCHEME_CAR(o_rename_stack)); + result_free_rename = SCHEME_CDR(result); + result = SCHEME_CAR(result); } else { EXPLAIN(fprintf(stderr, "%d No match %s\n", depth, scheme_write_to_string(key, 0))); if (SAME_OBJ(key, scheme_true)) { @@ -3689,6 +4006,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, if (SAME_OBJ(key, result)) { EXPLAIN(fprintf(stderr, "%d Match %s\n", depth, scheme_write_to_string(key, 0))); result = rename_stack[stack_pos - 2]; + result_free_rename = rename_stack[stack_pos - 3]; did_lexical = 1; } else { EXPLAIN(fprintf(stderr, "%d No match %s\n", depth, scheme_write_to_string(key, 0))); @@ -3697,14 +4015,65 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, did_lexical = 0; } } - stack_pos -= 2; + stack_pos -= 3; } if (!did_lexical) { result = mresult; if (_binding_marks_skipped) *_binding_marks_skipped = mresult_skipped; - } else if (get_names) - get_names[0] = scheme_undefined; + if (mresult_depends_unsealed) + depends_on_unsealed_rib = 1; + } else { + if (get_free_id_info && !SCHEME_VOIDP(result_free_rename)) { + Scheme_Object *orig; + int rib_dep = 0; + orig = result_free_rename; + result_free_rename = SCHEME_VEC_ELS(orig)[0]; + if (SCHEME_PAIRP(result_free_rename) && SCHEME_STXP(SCHEME_CAR(result_free_rename))) { + phase = SCHEME_CDR(result_free_rename); + if (!SCHEME_FALSEP(SCHEME_VEC_ELS(orig)[1])) + 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); + 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)); + } else if (SCHEME_PAIRP(result_free_rename) && SCHEME_SYMBOLP(SCHEME_CDR(result_free_rename))) { + if (get_names) + get_names[1] = SCHEME_CAR(result_free_rename); + result = SCHEME_CDR(result_free_rename); + if (get_names) + get_names[0] = scheme_undefined; + } else if (SCHEME_VECTORP(result_free_rename)) { + result = SCHEME_VEC_ELS(result_free_rename)[0]; + if (get_names) { + get_names[0] = SCHEME_VEC_ELS(result_free_rename)[1]; + get_names[1] = SCHEME_VEC_ELS(result_free_rename)[2]; + get_names[2] = SCHEME_VEC_ELS(result_free_rename)[3]; + 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]; + } + } else { + if (get_names) + get_names[1] = SCHEME_CAR(result_free_rename); + result = scheme_false; + } + if (rib_dep) + depends_on_unsealed_rib = 1; + if (SAME_TYPE(SCHEME_TYPE(result), scheme_module_index_type)) + result = scheme_modidx_shift(result, SCHEME_VEC_ELS(orig)[2], SCHEME_VEC_ELS(orig)[3]); + } else { + if (get_names) { + get_names[0] = scheme_undefined; + get_names[1] = NULL; + } + } + } if (_depends_on_unsealed_rib) *_depends_on_unsealed_rib = depends_on_unsealed_rib; @@ -3748,13 +4117,13 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, EXPLAIN(fprintf(stderr, "%d {unmarshal}\n", depth)); unmarshal_rename(mrn, modidx_shift_from, modidx_shift_to, export_registry); } - - if (mrn->marked_names) { + + if (mrn->marked_names) { /* Resolve based on rest of 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, skip_ribs, NULL, NULL, depth+1); + bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, recur_skip_ribs, NULL, NULL, depth+1, 0); if (SCHEME_FALSEP(bdg)) { if (!floating_checked) { floating = check_floating_id(a); @@ -3784,7 +4153,21 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, EXPLAIN(fprintf(stderr, "%d search %s\n", depth, scheme_write_to_string(glob_id, 0))); - rename = scheme_hash_get(mrn->ht, glob_id); + if (get_free_id_info && 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); + if (!sealed) + mresult_depends_unsealed = 1; + } + } else + rename = NULL; + if (!rename) + 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) { @@ -3794,7 +4177,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, get_names_done = 0; if (!rename) { EXPLAIN(fprintf(stderr, "%d in pes\n", depth)); - rename = search_shared_pes(mrn->shared_pes, glob_id, a, get_names, 0, depth); + rename = search_shared_pes(mrn->shared_pes, glob_id, a, get_names, 0, depth, &skipped); if (rename) get_names_done = 1; } @@ -3802,6 +4185,9 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, EXPLAIN(fprintf(stderr, "%d search result: %p\n", depth, rename)); if (rename) { + if (mrn->sealed < STX_SEAL_BOUND) + mresult_depends_unsealed = 1; + if (mrn->kind == mzMOD_RENAME_MARKED) { /* One job of a mzMOD_RENAME_MARKED renamer is to replace any binding that might have come from the identifier in its source @@ -3811,90 +4197,105 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, } /* match; set mresult, which is used in the case of no lexical capture: */ - if (SCHEME_PAIRP(rename)) - mresult = SCHEME_CAR(rename); - else - mresult = rename; - - if (modidx_shift_from) - mresult = scheme_modidx_shift(mresult, - modidx_shift_from, - modidx_shift_to); - mresult_skipped = skipped; + + if (SCHEME_BOXP(rename)) { + /* This should only happen for mappings from free_id_renames */ + mresult = SCHEME_BOX_VAL(rename); + if (get_names) { + if (SCHEME_FALSEP(SCHEME_CDR(mresult))) + get_names[0] = NULL; + else + get_names[0] = scheme_undefined; + get_names[1] = SCHEME_CAR(mresult); + } + mresult = SCHEME_CDR(mresult); + } else { + if (SCHEME_PAIRP(rename)) + mresult = SCHEME_CAR(rename); + else + mresult = rename; + + if (modidx_shift_from) + mresult = scheme_modidx_shift(mresult, + modidx_shift_from, + modidx_shift_to); - if (get_names) { - int no_shift = 0; + if (get_names) { + int no_shift = 0; - if (!get_names_done) { - if (SCHEME_PAIRP(rename)) { - if (nom_mod_p(rename)) { - /* (cons modidx nominal_modidx) case */ - get_names[0] = glob_id; - get_names[1] = SCHEME_CDR(rename); - get_names[2] = get_names[0]; - } else { - rename = SCHEME_CDR(rename); - if (SCHEME_PAIRP(rename)) { - /* (list* modidx [mod-phase] exportname nominal_modidx nominal_exportname) case */ - if (SCHEME_INTP(SCHEME_CAR(rename)) - || SCHEME_FALSEP(SCHEME_CAR(rename))) { - get_names[3] = SCHEME_CAR(rename); - rename = SCHEME_CDR(rename); - } - get_names[0] = SCHEME_CAR(rename); - get_names[1] = SCHEME_CADR(rename); - if (SCHEME_PAIRP(get_names[1])) { - get_names[4] = SCHEME_CDR(get_names[1]); - get_names[1] = SCHEME_CAR(get_names[1]); - if (SCHEME_PAIRP(get_names[4])) { - get_names[5] = SCHEME_CDR(get_names[4]); - get_names[4] = SCHEME_CAR(get_names[4]); - } else { - get_names[5] = get_names[3]; - } - } - get_names[2] = SCHEME_CDDR(rename); + if (!get_names_done) { + if (SCHEME_PAIRP(rename)) { + if (nom_mod_p(rename)) { + /* (cons modidx nominal_modidx) case */ + get_names[0] = glob_id; + get_names[1] = SCHEME_CDR(rename); + get_names[2] = get_names[0]; } else { - /* (cons modidx exportname) case */ - get_names[0] = rename; - get_names[2] = NULL; /* finish below */ + rename = SCHEME_CDR(rename); + if (SCHEME_PAIRP(rename)) { + /* (list* modidx [mod-phase] exportname nominal_modidx nominal_exportname) case */ + if (SCHEME_INTP(SCHEME_CAR(rename)) + || SCHEME_FALSEP(SCHEME_CAR(rename))) { + get_names[3] = SCHEME_CAR(rename); + rename = SCHEME_CDR(rename); + } + get_names[0] = SCHEME_CAR(rename); + get_names[1] = SCHEME_CADR(rename); + if (SCHEME_PAIRP(get_names[1])) { + get_names[4] = SCHEME_CDR(get_names[1]); + get_names[1] = SCHEME_CAR(get_names[1]); + if (SCHEME_PAIRP(get_names[4])) { + get_names[5] = SCHEME_CDR(get_names[4]); + get_names[4] = SCHEME_CAR(get_names[4]); + } else { + get_names[5] = get_names[3]; + } + } + get_names[2] = SCHEME_CDDR(rename); + } else { + /* (cons modidx exportname) case */ + get_names[0] = rename; + get_names[2] = NULL; /* finish below */ + } + } + } else { + get_names[0] = glob_id; + get_names[2] = NULL; /* finish below */ + } + + if (!get_names[2]) { + get_names[2] = get_names[0]; + if (nominal) + get_names[1] = nominal; + else { + no_shift = 1; + get_names[1] = mresult; } } - } else { - get_names[0] = glob_id; - get_names[2] = NULL; /* finish below */ - } - - if (!get_names[2]) { - get_names[2] = get_names[0]; - if (nominal) - get_names[1] = nominal; - else { - no_shift = 1; - get_names[1] = mresult; + if (!get_names[4]) { + GC_CAN_IGNORE Scheme_Object *pi; + pi = phase_to_index(mrn->phase); + get_names[4] = pi; + } + if (!get_names[5]) { + get_names[5] = get_names[3]; } } - if (!get_names[4]) { - GC_CAN_IGNORE Scheme_Object *pi; - pi = phase_to_index(mrn->phase); - get_names[4] = pi; - } - if (!get_names[5]) { - get_names[5] = get_names[3]; - } - } - if (modidx_shift_from && !no_shift) { - Scheme_Object *nom; - nom = get_names[1]; - nom = scheme_modidx_shift(nom, - modidx_shift_from, - modidx_shift_to); - get_names[1] = nom; + if (modidx_shift_from && !no_shift) { + Scheme_Object *nom; + nom = get_names[1]; + nom = scheme_modidx_shift(nom, + modidx_shift_from, + modidx_shift_to); + get_names[1] = nom; + } } } - } else { + } else { + if (mrn->sealed < STX_SEAL_ALL) + mresult_depends_unsealed = 1; mresult = scheme_false; mresult_skipped = -1; if (get_names) @@ -3986,27 +4387,42 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, int same; { - Scheme_Object *other_env, *envname; + Scheme_Object *other_env, *envname, *free_id_rename; if (SCHEME_SYMBOLP(renamed)) { /* Simplified table */ other_env = scheme_false; envname = SCHEME_VEC_ELS(rename)[2+c+ri]; + if (SCHEME_PAIRP(envname)) { + free_id_rename = SCHEME_CDR(envname); + envname = SCHEME_CAR(envname); + } else + free_id_rename = scheme_void; same = 1; no_lexical = 1; /* simplified table always has final result */ - EXPLAIN(fprintf(stderr, "%d Targes %s <- %s\n", depth, + EXPLAIN(fprintf(stderr, "%d Targes %s <- %s %p\n", depth, scheme_write_to_string(envname, 0), - scheme_write_to_string(other_env, 0))); + scheme_write_to_string(other_env, 0), + free_id_rename)); } else { envname = SCHEME_VEC_ELS(rename)[0]; other_env = SCHEME_VEC_ELS(rename)[2+c+ri]; - + if (SCHEME_PAIRP(other_env)) + free_id_rename = SCHEME_CDR(other_env); + else + free_id_rename = scheme_void; + other_env = filter_cached_env(other_env, recur_skip_ribs); + 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); - if (!is_rib && !rib_dep) - SCHEME_VEC_ELS(rename)[2+c+ri] = other_env; + other_env = resolve_env(NULL, renamed, 0, 0, NULL, recur_skip_ribs, NULL, &rib_dep, depth+1, 0); + { + Scheme_Object *e; + e = extend_cached_env(SCHEME_VEC_ELS(rename)[2+c+ri], other_env, recur_skip_ribs, + (is_rib && !(*is_rib->sealed)) || rib_dep); + SCHEME_VEC_ELS(rename)[2+c+ri] = e; + } if (rib_dep) depends_on_unsealed_rib = 1; SCHEME_USE_FUEL(1); @@ -4033,11 +4449,22 @@ 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)) { + /* Need to remember phase ad shifts for free-id=? rename: */ + Scheme_Object *vec; + vec = scheme_make_vector(4, NULL); + SCHEME_VEC_ELS(vec)[0] = free_id_rename; + SCHEME_VEC_ELS(vec)[1] = phase; + SCHEME_VEC_ELS(vec)[2] = modidx_shift_from; + SCHEME_VEC_ELS(vec)[3] = modidx_shift_to; + free_id_rename = vec; + } if (stack_pos < QUICK_STACK_SIZE) { + rename_stack[stack_pos++] = free_id_rename; rename_stack[stack_pos++] = envname; rename_stack[stack_pos++] = other_env; } else { - o_rename_stack = CONS(CONS(other_env, envname), + o_rename_stack = CONS(CONS(other_env, CONS(envname, free_id_rename)), o_rename_stack); } if (is_rib) { @@ -4065,6 +4492,8 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, } } if (rib) { + if (!*rib->sealed) + depends_on_unsealed_rib = 1; if (nonempty_rib(rib)) { if (SAME_OBJ(did_rib, rib)) { EXPLAIN(fprintf(stderr, "%d Did rib\n", depth)); @@ -4106,18 +4535,22 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, } } -static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_phase) +static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_phase, int use_free_id_renames) /* 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=?. */ + free-identifier=?. We do have to look at lexical renames to check for + equivalences installed on detection of make-rename-transformer, but at least + we can normally cache the result. */ { 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; Scheme_Object *phase = orig_phase; Scheme_Object *bdg = NULL, *floating = NULL; - if (SAME_OBJ(phase, scheme_make_integer(0)) + if (!use_free_id_renames + && SAME_OBJ(phase, scheme_make_integer(0)) && ((Scheme_Stx *)a)->u.modinfo_cache) return ((Scheme_Stx *)a)->u.modinfo_cache; @@ -4135,7 +4568,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))) + if (can_cache && SAME_OBJ(orig_phase, scheme_make_integer(0)) && !use_free_id_renames) ((Scheme_Stx *)a)->u.modinfo_cache = result; return result; @@ -4176,13 +4609,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); + resolve_env(NULL, a, orig_phase, 1, NULL, NULL, NULL, NULL, 0, 0); } 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); + bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, NULL, NULL, NULL, 0, 0); if (SCHEME_FALSEP(bdg)) { if (!floating_checked) { floating = check_floating_id(a); @@ -4192,22 +4625,46 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ } /* Remap id based on marks and rest-of-wraps resolution: */ glob_id = scheme_tl_id_sym((Scheme_Env *)mrn->marked_names, a, bdg, 0, NULL, NULL); + + if (SCHEME_TRUEP(bdg) + && !SAME_OBJ(glob_id, SCHEME_STX_VAL(a))) { + /* See "Even if this module doesn't match, the lex-renamed id" in resolve_env() */ + no_lexical = 1; + } } else glob_id = SCHEME_STX_VAL(a); - rename = scheme_hash_get(mrn->ht, glob_id); + if (use_free_id_renames && 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); + if (!sealed) + sealed = 0; + } + } else + rename = NULL; + if (!rename) + 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); + result = search_shared_pes(mrn->shared_pes, glob_id, a, NULL, 1, 0, NULL); else { /* match; set result: */ if (mrn->kind == mzMOD_RENAME_MARKED) skip_other_mods = 1; - if (SCHEME_PAIRP(rename)) { + if (SCHEME_BOXP(rename)) { + /* only happens with free_id_renames */ + rename = SCHEME_BOX_VAL(rename); + result = SCHEME_CAR(rename); + } else if (SCHEME_PAIRP(rename)) { if (nom_mod_p(rename)) { result = glob_id; } else { @@ -4229,10 +4686,98 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ n = SCHEME_VEC_ELS(vec)[0]; if (SCHEME_TRUEP(phase)) phase = scheme_bin_minus(phase, n); + } else if (!no_lexical + && (SCHEME_VECTORP(WRAP_POS_FIRST(wraps)) + || SCHEME_RIBP(WRAP_POS_FIRST(wraps)))) { + /* Lexical rename */ + Scheme_Object *rename, *renamed, *renames; + Scheme_Lexical_Rib *rib; + int ri, istart, iend; + + rename = WRAP_POS_FIRST(wraps); + if (SCHEME_RIBP(rename)) { + rib = ((Scheme_Lexical_Rib *)rename)->next; + rename = NULL; + } else { + rib = NULL; + if (SCHEME_FALSEP(SCHEME_VEC_ELS(rename)[0])) { + /* No free-id=? renames here. */ + rename = NULL; + } + } + + do { + if (rib) { + if (!*rib->sealed) sealed = 0; + rename = rib->rename; + rib = rib->next; + } + + if (rename) { + int c = SCHEME_RENAME_LEN(rename); + + /* Get index from hash table, if there is one: */ + if (!SCHEME_FALSEP(SCHEME_VEC_ELS(rename)[1])) { + void *pos; + pos = scheme_hash_get((Scheme_Hash_Table *)(SCHEME_VEC_ELS(rename)[1]), SCHEME_STX_VAL(a)); + if (pos) { + istart = SCHEME_INT_VAL(pos); + if (istart < 0) { + /* -1 indicates multiple slots matching this name. */ + istart = 0; + iend = c; + } else + iend = istart + 1; + } else { + istart = 0; + iend = 0; + } + } else { + istart = 0; + iend = c; + } + + for (ri = istart; ri < iend; ri++) { + renamed = SCHEME_VEC_ELS(rename)[2+ri]; + if (SAME_OBJ(SCHEME_STX_VAL(a), SCHEME_STX_SYM(renamed))) { + /* Check for free-id mapping: */ + renames = SCHEME_VEC_ELS(rename)[2 + ri + c]; + if (SCHEME_PAIRP(renames)) { + /* Has a relevant-looking free-id mapping. + Give up on the "fast" traversal. */ + Scheme_Object *modname, *names[6]; + int rib_dep; + + names[0] = NULL; + names[1] = NULL; + names[3] = scheme_make_integer(0); + names[4] = NULL; + names[5] = NULL; + + modname = resolve_env(NULL, a, orig_phase, 1, names, NULL, NULL, &rib_dep, 0, 1); + if (rib_dep) + sealed = 0; + + if (!SCHEME_FALSEP(modname) + && !SAME_OBJ(names[0], scheme_undefined)) { + result = names[0]; + } else { + result = names[1]; /* can be NULL or alternate name */ + } + + WRAP_POS_INIT_END(wraps); + rib = NULL; + break; + } + } + } + } + } while (rib); } /* Keep looking: */ - WRAP_POS_INC(wraps); + if (!WRAP_POS_END_P(wraps)) + WRAP_POS_INC(wraps); } } @@ -4243,16 +4788,16 @@ int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *pha if (!a || !b) return (a == b); + if (SCHEME_STXP(b)) + bsym = get_module_src_name(b, phase, !asym); + else + bsym = b; if (!asym) { if (SCHEME_STXP(a)) - asym = get_module_src_name(a, phase); + asym = get_module_src_name(a, phase, 1); else asym = a; } - if (SCHEME_STXP(b)) - bsym = get_module_src_name(b, phase); - else - bsym = b; /* Same name? */ if (!SAME_OBJ(asym, bsym)) @@ -4261,8 +4806,8 @@ 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); - b = resolve_env(NULL, b, phase, 1, NULL, NULL, NULL, NULL, 0); + 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); if (SAME_TYPE(SCHEME_TYPE(a), scheme_module_index_type)) a = scheme_module_resolve(a, 0); @@ -4281,34 +4826,47 @@ 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); + return get_module_src_name(a, phase, 0); else return a; } -Scheme_Object *scheme_stx_module_name(Scheme_Object **a, Scheme_Object *phase, - Scheme_Object **nominal_modidx, - Scheme_Object **nominal_name, - Scheme_Object **mod_phase, - Scheme_Object **src_phase_index, - Scheme_Object **nominal_src_phase) +Scheme_Object *scheme_stx_module_name(int recur, + Scheme_Object **a, Scheme_Object *phase, + Scheme_Object **nominal_modidx, /* how it was imported */ + Scheme_Object **nominal_name, /* imported as name */ + Scheme_Object **mod_phase, /* original defn phase level */ + 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) /* If module bound, result is module idx, and a is set to source name. - If lexically bound, result is scheme_undefined and a is unchanged. - If neither, result is NULL and a is unchanged. */ + If lexically bound, result is scheme_undefined, a is unchanged, + and nominal_name is NULL or a free_id=? renamed id. + If neither, result is NULL, a is unchanged, and + and nominal_name is NULL or a free_id=? renamed id. */ { if (SCHEME_STXP(*a)) { Scheme_Object *modname, *names[6]; + int rib_dep; names[0] = NULL; + names[1] = NULL; names[3] = scheme_make_integer(0); names[4] = NULL; names[5] = NULL; - modname = resolve_env(NULL, *a, phase, 1, names, NULL, NULL, NULL, 0); + modname = resolve_env(NULL, *a, phase, 1, names, NULL, NULL, _sealed ? &rib_dep : NULL, 0, recur); + + if (_sealed) *_sealed = !rib_dep; if (names[0]) { if (SAME_OBJ(names[0], scheme_undefined)) { - return scheme_undefined; + if (lex_env) + *lex_env = modname; + if (nominal_name) + *nominal_name = names[1]; + return scheme_undefined; } else { *a = names[0]; if (nominal_modidx) @@ -4323,10 +4881,15 @@ Scheme_Object *scheme_stx_module_name(Scheme_Object **a, Scheme_Object *phase, *nominal_src_phase = names[5]; return modname; } - } else + } else { + if (nominal_name) *nominal_name = names[1]; return NULL; - } else + } + } else { + if (nominal_name) *nominal_name = NULL; + if (_sealed) *_sealed = 1; return NULL; + } } int scheme_stx_ribs_matter(Scheme_Object *a, Scheme_Object *skip_ribs) @@ -4339,8 +4902,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); - m2 = resolve_env(NULL, a, scheme_make_integer(0), 1, NULL, skips, NULL, NULL, 0); + 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); return !SAME_OBJ(m1, m2); } @@ -4351,7 +4914,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); + r = resolve_env(NULL, a, scheme_make_integer(0), 0, NULL, NULL, NULL, NULL, 0, 0); if (SCHEME_FALSEP(r)) r = check_floating_id(a); @@ -4383,13 +4946,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); + ae = resolve_env(NULL, a, phase, 0, NULL, NULL, NULL, NULL, 0, 0); /* 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); + be = resolve_env(NULL, b, phase, 0, NULL, NULL, NULL, NULL, 0, 0); /* No need to module_resolve be, because we ignored module renamings. */ } @@ -4418,9 +4981,9 @@ int scheme_stx_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase #if EXPLAIN_RESOLVE Scheme_Object *scheme_explain_resolve_env(Scheme_Object *a) { - explain_resolves++; - a = resolve_env(NULL, a, 0, 0, NULL, NULL, NULL, NULL, 0); - --explain_resolves; + scheme_explain_resolves++; + a = resolve_env(NULL, a, 0, 0, NULL, NULL, NULL, NULL, 0, 1); + --scheme_explain_resolves; return a; } #endif @@ -4806,6 +5369,49 @@ static void print_skips(Scheme_Object *skips) #define EXPLAIN_S(x) /* empty */ #endif +static Scheme_Object *extract_free_id_info(Scheme_Object *id) +{ + Scheme_Object *bind; + Scheme_Object *nominal_modidx; + Scheme_Object *nominal_name, *nom2; + Scheme_Object *mod_phase; + Scheme_Object *src_phase_index; + Scheme_Object *nominal_src_phase; + Scheme_Object *lex_env = NULL; + Scheme_Object *vec, *phase; + + phase = SCHEME_CDR(id); + id = SCHEME_CAR(id); + + nom2 = scheme_stx_property(id, nominal_id_symbol, NULL); + + bind = scheme_stx_module_name(1, + &id, phase, &nominal_modidx, &nominal_name, + &mod_phase, &src_phase_index, &nominal_src_phase, + &lex_env, NULL); + + if (SCHEME_SYMBOLP(nom2)) + nominal_name = nom2; + if (!nominal_name) + nominal_name = SCHEME_STX_VAL(id); + + if (!bind) + return CONS(nominal_name, scheme_false); + else if (SAME_OBJ(bind, scheme_undefined)) + return CONS(nominal_name, lex_env); + else { + vec = scheme_make_vector(7, NULL); + SCHEME_VEC_ELS(vec)[0] = bind; + SCHEME_VEC_ELS(vec)[1] = id; + SCHEME_VEC_ELS(vec)[2] = nominal_modidx; + SCHEME_VEC_ELS(vec)[3] = nominal_name; + SCHEME_VEC_ELS(vec)[4] = mod_phase; + SCHEME_VEC_ELS(vec)[5] = src_phase_index; + SCHEME_VEC_ELS(vec)[6] = nominal_src_phase; + return vec; + } +} + static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_cache) { WRAP_POS w, prev, w2; @@ -4814,7 +5420,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab Scheme_Object *v, *v2, *v2l, *stx, *name, *svl, *end_mutable = NULL; Scheme_Lexical_Rib *did_rib = NULL; Scheme_Hash_Table *skip_ribs_ht = NULL, *prev_skip_ribs_ht; - int copy_on_write; + int copy_on_write, no_rib_mutation = 1; long size, vsize, psize, i, j, pos; /* Although it makes no sense to simplify the rename table itself, @@ -4886,7 +5492,12 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab if (SCHEME_RIBP(v)) { /* A rib certainly isn't simplified yet. */ Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)v; + no_rib_mutation = 0; add = 1; + if (!*rib->sealed) { + scheme_signal_error("compile: unsealed local-definition context found in fully expanded form"); + return NULL; + } if (SAME_OBJ(did_rib, rib) || !nonempty_rib(rib)) { skip_this = 1; @@ -4894,10 +5505,6 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab scheme_write_to_string(rib->timestamp, NULL))); } else { did_rib = rib; - if (!*rib->sealed) { - scheme_signal_error("compile: unsealed local-definition context found in fully expanded form"); - return NULL; - } prec_ribs = add_skip_set(rib->timestamp, prec_ribs); EXPLAIN_S(fprintf(stderr, " down rib %p=%s\n", rib, @@ -4924,9 +5531,10 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab /* No. Should we skip? */ Scheme_Object *other_env; other_env = SCHEME_VEC_ELS(rib->rename)[2+vsize+i]; + 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); + other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0, 0); if (rib_dep) { scheme_signal_error("compile: unsealed local-definition context found in fully expanded form"); return NULL; @@ -5082,7 +5690,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab answer applies. */ Scheme_Object *ok = NULL, *ok_replace = NULL; int ok_replace_index = 0; - Scheme_Object *other_env; + Scheme_Object *other_env, *free_id_rename, *prev_env, *orig_prev_env; if (rib) { EXPLAIN_S(fprintf(stderr, " resolve %s %s (%d)\n", @@ -5092,15 +5700,26 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab } other_env = SCHEME_VEC_ELS(v)[2+vvsize+ii]; + if (SCHEME_PAIRP(other_env)) + free_id_rename = extract_free_id_info(SCHEME_CDR(other_env)); + else + free_id_rename = NULL; + 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); + other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0, 0); if (rib_dep) { scheme_signal_error("compile: unsealed local-definition context found in fully expanded form"); return NULL; } - if (!rib) - SCHEME_VEC_ELS(v)[2+vvsize+ii] = other_env; + if (!prec_ribs) { + if (free_id_rename) + ok = CONS(other_env, free_id_rename); + else + ok = other_env; + SCHEME_VEC_ELS(v)[2+vvsize+ii] = ok; + ok = NULL; + } } if (!WRAP_POS_END_P(prev) @@ -5115,7 +5734,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab } if (other_env) { - /* A simplified table need to have the final answer, so + /* A simplified table needs to have the final answer, so fold conversions from the rest of the wraps. In the case of ribs, the "rest" can include earlier rib renamings. Otherwise, check simplications accumulated in v2l (possibly from a @@ -5127,10 +5746,15 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab for (j = 0; j < done_rib_pos; j++) { if (SAME_OBJ(SCHEME_VEC_ELS(v2)[2+j], name)) { rib_found = 1; - if (SAME_OBJ(SCHEME_VEC_ELS(v2)[2+size+j], other_env)) { + prev_env = SCHEME_VEC_ELS(v2)[2+size+j]; + orig_prev_env = prev_env; + if (SCHEME_PAIRP(prev_env)) prev_env = SCHEME_CAR(prev_env); + if (SAME_OBJ(prev_env, other_env)) { ok = SCHEME_VEC_ELS(v)[0]; ok_replace = v2; ok_replace_index = 2 + size + j; + if (!free_id_rename && SCHEME_PAIRP(orig_prev_env)) + free_id_rename = SCHEME_CDR(orig_prev_env); } else { EXPLAIN_S(fprintf(stderr, " not matching prev rib\n")); ok = NULL; @@ -5153,8 +5777,13 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab psize = SCHEME_RENAME_LEN(vp); for (j = 0; j < psize; j++) { if (SAME_OBJ(SCHEME_VEC_ELS(vp)[2+j], name)) { - if (SAME_OBJ(SCHEME_VEC_ELS(vp)[2+psize+j], other_env)) { + prev_env = SCHEME_VEC_ELS(vp)[2+psize+j]; + orig_prev_env = prev_env; + if (SCHEME_PAIRP(prev_env)) prev_env = SCHEME_CAR(prev_env); + if (SAME_OBJ(prev_env, other_env)) { ok = SCHEME_VEC_ELS(v)[0]; + if (!free_id_rename && SCHEME_PAIRP(orig_prev_env)) + free_id_rename = SCHEME_CDR(orig_prev_env); } else { EXPLAIN_S(fprintf(stderr, " not matching deeper %s\n", @@ -5203,6 +5832,8 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab } if (ok) { + if (free_id_rename) + ok = CONS(ok, free_id_rename); if (ok_replace) { EXPLAIN_S(fprintf(stderr, " replace mapping %s\n", scheme_write_to_string(ok, NULL))); @@ -5226,36 +5857,42 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab ii++; } - if (pos != size) { - /* Shrink simplified vector */ - if (!pos) - v2 = empty_simplified; - else { - v = v2; - v2 = scheme_make_vector(2 + (2 * pos), NULL); - for (i = 0; i < pos; i++) { - SCHEME_VEC_ELS(v2)[2+i] = SCHEME_VEC_ELS(v)[2+i]; - SCHEME_VEC_ELS(v2)[2+pos+i] = SCHEME_VEC_ELS(v)[2+size+i]; - } - } - } - - SCHEME_VEC_ELS(v2)[0] = scheme_false; - SCHEME_VEC_ELS(v2)[1] = scheme_false; - - { - /* Sometimes we generate the same simplified lex table, so - look for an equivalent one in the cache. */ - v = scheme_hash_get(lex_cache, scheme_true); - if (!v) { - v = (Scheme_Object *)scheme_make_hash_table_equal(); - scheme_hash_set(lex_cache, scheme_true, v); + if (!pos) + v2 = empty_simplified; + else { + if (pos != size) { + /* Shrink simplified vector */ + v = v2; + v2 = scheme_make_vector(2 + (2 * pos), NULL); + for (i = 0; i < pos; i++) { + SCHEME_VEC_ELS(v2)[2+i] = SCHEME_VEC_ELS(v)[2+i]; + SCHEME_VEC_ELS(v2)[2+pos+i] = SCHEME_VEC_ELS(v)[2+size+i]; + } + } + + SCHEME_VEC_ELS(v2)[0] = scheme_false; + for (i = 0; i < pos; i++) { + if (!SCHEME_SYMBOLP(SCHEME_VEC_ELS(v2)[2+pos+i])) + SCHEME_VEC_ELS(v2)[0] = scheme_true; + } + + SCHEME_VEC_ELS(v2)[1] = scheme_false; + maybe_install_rename_hash_table(v2); + + if (no_rib_mutation) { + /* Sometimes we generate the same simplified lex table, so + look for an equivalent one in the cache. */ + v = scheme_hash_get(lex_cache, scheme_true); + if (!v) { + v = (Scheme_Object *)scheme_make_hash_table_equal(); + scheme_hash_set(lex_cache, scheme_true, v); + } + svl = scheme_hash_get((Scheme_Hash_Table *)v, v2); + if (svl) + v2 = svl; + else + scheme_hash_set((Scheme_Hash_Table *)v, v2, v2); } - svl = scheme_hash_get((Scheme_Hash_Table *)v, v2); - if (svl) - v2 = svl; - else - scheme_hash_set((Scheme_Hash_Table *)v, v2, v2); } v2l = CONS(v2, v2l); @@ -5418,6 +6055,7 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, /* Not useful if there's no marked names. */ redundant = ((mrn->sealed >= STX_SEAL_ALL) && (!mrn->marked_names || !mrn->marked_names->count) + && (!mrn->free_id_renames || !mrn->free_id_renames->count) && SCHEME_NULLP(mrn->shared_pes)); if (!redundant) { /* Otherwise, watch out for multiple instances of the same rename: */ @@ -5473,6 +6111,32 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, if (just_simplify) { stack = CONS((Scheme_Object *)mrn, stack); } else { + if (mrn->free_id_renames) { + /* resolve all renamings */ + int i; + Scheme_Object *b; + for (i = mrn->free_id_renames->size; i--; ) { + if (mrn->free_id_renames->vals[i]) { + if (SCHEME_STXP(mrn->free_id_renames->vals[i])) { + int sealed; + b = extract_module_free_id_binding((Scheme_Object *)mrn, + mrn->free_id_renames->keys[i], + mrn->free_id_renames->vals[i], + &sealed); + 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"); + } + scheme_hash_set(mrn->free_id_renames, mrn->free_id_renames->keys[i], b); + } + } + } + } + if (mrn->kind == mzMOD_RENAME_TOPLEVEL) { if (same_phase(mrn->phase, scheme_make_integer(0))) stack = CONS(scheme_true, stack); @@ -5483,21 +6147,34 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, local_key = scheme_marshal_lookup(mt, (Scheme_Object *)mrn); if (!local_key) { - /* Convert hash table to vector: */ + /* Convert hash table to vector, etc.: */ int i, j, count = 0; - Scheme_Object *l; + Scheme_Hash_Table *ht; + Scheme_Object *l, *fil; - count = mrn->ht->count; - - l = scheme_make_vector(count * 2, NULL); - - for (i = mrn->ht->size, j = 0; i--; ) { - if (mrn->ht->vals[i]) { - SCHEME_VEC_ELS(l)[j++] = mrn->ht->keys[i]; - SCHEME_VEC_ELS(l)[j++] = mrn->ht->vals[i]; + ht = mrn->ht; + count = ht->count; + l = scheme_make_vector(count * 2, NULL); + 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]; } } + ht = mrn->free_id_renames; + if (ht && ht->count) { + count = ht->count; + fil = scheme_make_vector(count * 2, NULL); + for (i = ht->size, j = 0; i--; ) { + if (ht->vals[i]) { + SCHEME_VEC_ELS(fil)[j++] = ht->keys[i]; + SCHEME_VEC_ELS(fil)[j++] = ht->vals[i]; + } + } + } else + fil = NULL; + if (mrn->marked_names && mrn->marked_names->count) { Scheme_Object *d = scheme_null, *p; @@ -5511,10 +6188,17 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, } } - l = CONS(l, d); - } else - l = CONS(l, scheme_null); - + if (fil) + fil = CONS(fil, d); + else + fil = d; + } else if (fil) + fil = CONS(fil, scheme_null); + else + fil = scheme_null; + + l = CONS(l, fil); + if (SCHEME_PAIRP(mrn->unmarshal_info)) l = CONS(mrn->unmarshal_info, l); @@ -6044,6 +6728,100 @@ static int ok_phase_index(Scheme_Object *o) { return ok_phase(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; + + if (!SCHEME_VECTORP(a)) return_NULL; + count = SCHEME_VEC_SIZE(a); + if (count & 0x1) return_NULL; + + for (i = 0; i < count; i+= 2) { + key = SCHEME_VEC_ELS(a)[i]; + p = SCHEME_VEC_ELS(a)[i+1]; + + if (!SCHEME_SYMBOLP(key)) return_NULL; + + if (SAME_TYPE(SCHEME_TYPE(p), scheme_module_index_type)) { + /* Ok */ + } else if (SCHEME_PAIRP(p)) { + Scheme_Object *midx; + + midx = SCHEME_CAR(p); + if (!SAME_TYPE(SCHEME_TYPE(midx), scheme_module_index_type)) + return_NULL; + + if (SCHEME_SYMBOLP(SCHEME_CDR(p))) { + /* Ok */ + } else if (SAME_TYPE(SCHEME_TYPE(SCHEME_CDR(p)), scheme_module_index_type)) { + /* Ok */ + } else { + Scheme_Object *ap, *bp; + + ap = SCHEME_CDR(p); + if (!SCHEME_PAIRP(ap)) + return_NULL; + + /* mod-phase, maybe */ + if (SCHEME_INTP(SCHEME_CAR(ap))) { + bp = SCHEME_CDR(ap); + } else + bp = ap; + + /* exportname */ + if (!SCHEME_PAIRP(bp)) + return_NULL; + ap = SCHEME_CAR(bp); + if (!SCHEME_SYMBOLP(ap)) + return_NULL; + + /* nominal_modidx_plus_phase */ + bp = SCHEME_CDR(bp); + if (!SCHEME_PAIRP(bp)) + return_NULL; + ap = SCHEME_CAR(bp); + if (SAME_TYPE(SCHEME_TYPE(ap), scheme_module_index_type)) { + /* Ok */ + } else if (SCHEME_PAIRP(ap)) { + if (!SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(ap)), scheme_module_index_type)) + return_NULL; + ap = SCHEME_CDR(ap); + /* import_phase_plus_nominal_phase */ + if (SCHEME_PAIRP(ap)) { + if (!ok_phase_index(SCHEME_CAR(ap))) return_NULL; + if (!ok_phase_index(SCHEME_CDR(ap))) return_NULL; + } else if (!ok_phase_index(ap)) + return_NULL; + } else + return_NULL; + + /* nominal_exportname */ + ap = SCHEME_CDR(bp); + if (!SCHEME_SYMBOLP(ap)) + return_NULL; + } + } else if (lex_ok) { + Scheme_Object *ap; + if (!SCHEME_BOXP(p)) + return_NULL; + ap = SCHEME_BOX_VAL(p); + if (!SCHEME_PAIRP(ap)) + return_NULL; + if (!SCHEME_SYMBOLP(SCHEME_CAR(ap))) + return_NULL; + ap = SCHEME_CDR(ap); + if (!SCHEME_SYMBOLP(ap) && !SCHEME_FALSEP(ap)) + return_NULL; + } else + return_NULL; + + scheme_hash_set(ht, key, p); + } + + return scheme_true; +} + static Scheme_Object *datum_to_wraps(Scheme_Object *w, Scheme_Unmarshal_Tables *ut) { @@ -6107,15 +6885,53 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w, if (!a) return_NULL; } else if (SCHEME_VECTORP(a)) { /* A (simplified) rename table. */ - int i = SCHEME_VEC_SIZE(a); + int sz = SCHEME_VEC_SIZE(a), cnt, i, any_free_id_renames = 0; + Scheme_Object *v; /* Make sure that it's a well-formed rename table. */ - if ((i < 2) || !SCHEME_FALSEP(SCHEME_VEC_ELS(a)[1])) + if (sz < 2) return_NULL; - while (i > 2) { - i--; - if (!SCHEME_SYMBOLP(SCHEME_VEC_ELS(a)[i])) + cnt = (sz - 2) >> 1; + for (i = 0; i < cnt; i++) { + if (!SCHEME_SYMBOLP(SCHEME_VEC_ELS(a)[i + 2])) return_NULL; + v = SCHEME_VEC_ELS(a)[i + cnt + 2]; + if (SCHEME_SYMBOLP(v)) { + /* simple target-environment symbol */ + } else if (SCHEME_PAIRP(v)) { + /* target-environment symbol paired with free-id=? rename info */ + any_free_id_renames = 1; + if (!SCHEME_SYMBOLP(SCHEME_CAR(v))) + return_NULL; + v = SCHEME_CDR(v); + if (SCHEME_PAIRP(v)) { + if (!SCHEME_SYMBOLP(SCHEME_CAR(v))) + return_NULL; + 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; + if (!SCHEME_MODIDXP(SCHEME_VEC_ELS(v)[0]) + || !SCHEME_SYMBOLP(SCHEME_VEC_ELS(v)[1]) + || !SCHEME_MODIDXP(SCHEME_VEC_ELS(v)[2]) + || !SCHEME_SYMBOLP(SCHEME_VEC_ELS(v)[3]) + || !ok_phase(SCHEME_VEC_ELS(v)[4]) + || !ok_phase(SCHEME_VEC_ELS(v)[5]) + || !ok_phase(SCHEME_VEC_ELS(v)[6])) + return_NULL; + } else + return_NULL; + } else + return_NULL; + } + + SCHEME_VEC_ELS(a)[0] = (any_free_id_renames ? scheme_true : scheme_false); + + if (!SCHEME_FALSEP(SCHEME_VEC_ELS(a)[1])) { + SCHEME_VEC_ELS(a)[1] = scheme_false; + maybe_install_rename_hash_table(a); } /* It's ok: */ @@ -6131,7 +6947,7 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w, Scheme_Object *mns; Module_Renames *mrn; Scheme_Object *p, *key; - int plus_kernel, i, count, kind; + int plus_kernel, kind; Scheme_Object *phase, *set_identity; if (!SCHEME_PAIRP(a)) return_NULL; @@ -6271,78 +7087,17 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w, mns = SCHEME_CDR(mns); } - if (!SCHEME_VECTORP(a)) return_NULL; - count = SCHEME_VEC_SIZE(a); - if (count & 0x1) return_NULL; + if (!datum_to_module_renames(a, mrn->ht, 0)) + return_NULL; - for (i = 0; i < count; i+= 2) { - key = SCHEME_VEC_ELS(a)[i]; - p = SCHEME_VEC_ELS(a)[i+1]; - - if (!SCHEME_SYMBOLP(key)) return_NULL; - - if (SAME_TYPE(SCHEME_TYPE(p), scheme_module_index_type)) { - /* Ok */ - } else if (SCHEME_PAIRP(p)) { - Scheme_Object *midx; - - midx = SCHEME_CAR(p); - if (!SAME_TYPE(SCHEME_TYPE(midx), scheme_module_index_type)) - return_NULL; - - if (SCHEME_SYMBOLP(SCHEME_CDR(p))) { - /* Ok */ - } else if (SAME_TYPE(SCHEME_TYPE(SCHEME_CDR(p)), scheme_module_index_type)) { - /* Ok */ - } else { - Scheme_Object *ap, *bp; - - ap = SCHEME_CDR(p); - if (!SCHEME_PAIRP(ap)) - return_NULL; - - /* mod-phase, maybe */ - if (SCHEME_INTP(SCHEME_CAR(ap))) { - bp = SCHEME_CDR(ap); - } else - bp = ap; - - /* exportname */ - if (!SCHEME_PAIRP(bp)) - return_NULL; - ap = SCHEME_CAR(bp); - if (!SCHEME_SYMBOLP(ap)) - return_NULL; - - /* nominal_modidx_plus_phase */ - bp = SCHEME_CDR(bp); - if (!SCHEME_PAIRP(bp)) - return_NULL; - ap = SCHEME_CAR(bp); - if (SAME_TYPE(SCHEME_TYPE(ap), scheme_module_index_type)) { - /* Ok */ - } else if (SCHEME_PAIRP(ap)) { - if (!SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(ap)), scheme_module_index_type)) - return_NULL; - ap = SCHEME_CDR(ap); - /* import_phase_plus_nominal_phase */ - if (SCHEME_PAIRP(ap)) { - if (!ok_phase_index(SCHEME_CAR(ap))) return_NULL; - if (!ok_phase_index(SCHEME_CDR(ap))) return_NULL; - } else if (!ok_phase_index(ap)) - return_NULL; - } else - return_NULL; - - /* nominal_exportname */ - ap = SCHEME_CDR(bp); - if (!SCHEME_SYMBOLP(ap)) - return_NULL; - } - } else - return_NULL; - - scheme_hash_set(mrn->ht, key, p); + /* Extract free-id=? renames, if any */ + if (SCHEME_PAIRP(mns) && SCHEME_VECTORP(SCHEME_CAR(mns))) { + Scheme_Hash_Table *ht; + ht = scheme_make_hash_table(SCHEME_hash_ptr); + mrn->free_id_renames = ht; + if (!datum_to_module_renames(SCHEME_CAR(mns), mrn->free_id_renames, 1)) + return_NULL; + mns = SCHEME_CDR(mns); } /* Extract the mark-rename table, if any: */ @@ -7045,7 +7800,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), + scheme_write_to_string(resolve_env(NULL, stx, 0, 0, NULL, NULL, NULL, NULL, 0, 0), NULL)); explain_simp = 1; } @@ -7063,7 +7818,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), + scheme_write_to_string(resolve_env(NULL, stx, 0, 0, NULL, NULL, NULL, NULL, 0, 0), NULL)); } #endif @@ -7555,7 +8310,7 @@ 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); + mod = resolve_env(NULL, argv[0], phase, 1, NULL, NULL, &skipped, NULL, 0, 1); if ((skipped == -1) && SCHEME_FALSEP(mod)) { /* For top-level bindings, need to check the current environment's table, @@ -7681,12 +8436,15 @@ static Scheme_Object *do_module_binding(char *name, int argc, Scheme_Object **ar phase = scheme_bin_plus(dphase, phase); } - m = scheme_stx_module_name(&a, + m = scheme_stx_module_name(1, + &a, phase, &nom_mod, &nom_a, &mod_phase, &src_phase_index, - &nominal_src_phase); + &nominal_src_phase, + NULL, + NULL); if (!m) return scheme_false; diff --git a/src/mzscheme/src/syntax.c b/src/mzscheme/src/syntax.c index b68e2f1b80..407abd05d4 100644 --- a/src/mzscheme/src/syntax.c +++ b/src/mzscheme/src/syntax.c @@ -1698,12 +1698,12 @@ set_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) { /* Redirect to a macro? */ - if (SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_set_macro_type)) { + if (scheme_is_set_transformer(SCHEME_PTR_VAL(var))) { form = scheme_apply_macro(name, menv, SCHEME_PTR_VAL(var), form, env, scheme_false, rec, drec, 1); return scheme_compile_expr(form, env, rec, drec); - } else if (SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_id_macro_type)) { - find_name = SCHEME_PTR_VAL(SCHEME_PTR_VAL(var)); + } else if (scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) { + find_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var)); find_name = scheme_stx_cert(find_name, scheme_false, menv, find_name, NULL, 1); SCHEME_USE_FUEL(1); menv = NULL; @@ -1787,7 +1787,7 @@ set_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, if ((erec[drec].depth != 0) && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) { /* Redirect to a macro? */ - if (SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_set_macro_type)) { + if (scheme_is_set_transformer(SCHEME_PTR_VAL(var))) { SCHEME_EXPAND_OBSERVE_ENTER_MACRO(erec[drec].observer, form); @@ -1801,9 +1801,9 @@ set_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, erec[drec].value_name = name; return scheme_expand_expr(form, env, erec, drec); - } else if (SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_id_macro_type)) { + } else if (scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) { Scheme_Object *new_name; - new_name = SCHEME_PTR_VAL(SCHEME_PTR_VAL(var)); + new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var)); new_name = scheme_stx_track(new_name, find_name, find_name); new_name = scheme_stx_cert(new_name, scheme_false, menv, find_name, NULL, 1); find_name = new_name; @@ -5732,14 +5732,13 @@ static void *eval_letmacro_rhs_k(void) return (void *)eval_letmacro_rhs(a, rhs_env, max_let_depth, rp, phase, certs); } - void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object *a, Scheme_Env *exp_env, Scheme_Object *insp, Scheme_Compile_Expand_Info *rec, int drec, Scheme_Comp_Env *stx_env, Scheme_Comp_Env *rhs_env, - int *_pos) + int *_pos, Scheme_Object *rename_rib) { - Scheme_Object **results, *l; + Scheme_Object **results, *l, *a_expr; Scheme_Comp_Env *eenv; Scheme_Object *certs; Resolve_Prefix *rp; @@ -5795,7 +5794,8 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer); - a = eval_letmacro_rhs(a, rhs_env, ri->max_let_depth, rp, eenv->genv->phase, certs); + a_expr = a; + a = eval_letmacro_rhs(a_expr, rhs_env, ri->max_let_depth, rp, eenv->genv->phase, certs); if (SAME_OBJ(a, SCHEME_MULTIPLE_VALUES)) { vc = scheme_current_thread->ku.multiple.count; @@ -5841,10 +5841,16 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object macro->type = scheme_macro_type; if (vc == 1) SCHEME_PTR_VAL(macro) = a; - else + else SCHEME_PTR_VAL(macro) = results[j]; scheme_set_local_syntax(i++, name, macro, stx_env); + + if (scheme_is_binding_rename_transformer(SCHEME_PTR_VAL(macro))) { + /* Install a free-id=? rename */ + scheme_install_free_id_rename(name, scheme_rename_transformer_id(SCHEME_PTR_VAL(macro)), rename_rib, + scheme_make_integer(rhs_env->genv->phase)); + } } *_pos = i; @@ -6033,7 +6039,7 @@ do_letrec_syntaxes(const char *where, stx_env->insp, rec, drec, stx_env, rhs_env, - &i); + &i, NULL); } } diff --git a/src/mzscheme/src/thread.c b/src/mzscheme/src/thread.c index 4f91a56160..4fff4b5ee6 100644 --- a/src/mzscheme/src/thread.c +++ b/src/mzscheme/src/thread.c @@ -114,10 +114,10 @@ static int swapping = 0; #endif extern void scheme_gmp_tls_init(long *s); -extern void scheme_gmp_tls_load(long *s); -extern void scheme_gmp_tls_unload(long *s); +extern void *scheme_gmp_tls_load(long *s); +extern void scheme_gmp_tls_unload(long *s, void *p); extern void scheme_gmp_tls_snapshot(long *s, long *save); -extern void scheme_gmp_tls_restore_snapshot(long *s, long *save, int do_free); +extern void scheme_gmp_tls_restore_snapshot(long *s, void *data, long *save, int do_free); static void check_ready_break(); @@ -363,6 +363,7 @@ static Scheme_Object *will_executor_go(int argc, Scheme_Object *args[]); static Scheme_Object *will_executor_sema(Scheme_Object *w, int *repost); static Scheme_Object *check_break_now(int argc, Scheme_Object *args[]); +static int syncing_ready(Scheme_Object *s, Scheme_Schedule_Info *sinfo); static void make_initial_config(Scheme_Thread *p); @@ -2511,7 +2512,9 @@ static void do_swap_thread() #if WATCH_FOR_NESTED_SWAPS swapping = 0; #endif - scheme_gmp_tls_unload(scheme_current_thread->gmp_tls); + scheme_gmp_tls_unload(scheme_current_thread->gmp_tls, scheme_current_thread->gmp_tls_data); + scheme_current_thread->gmp_tls_data = NULL; + { Scheme_Object *l, *o; Scheme_Closure_Func f; @@ -2529,6 +2532,12 @@ static void do_swap_thread() scheme_takeover_stacks(scheme_current_thread); } + { + long cpm; + cpm = scheme_get_process_milliseconds(); + scheme_current_thread->current_start_process_msec = cpm; + } + if (scheme_current_thread->return_marks_to) { stash_current_marks(); goto start; @@ -2536,6 +2545,12 @@ static void do_swap_thread() } else { Scheme_Thread *new_thread = swap_target; + { + long cpm; + cpm = scheme_get_process_milliseconds(); + scheme_current_thread->accum_process_msec += (cpm - scheme_current_thread->current_start_process_msec); + } + swap_target = NULL; swap_no_setjmp = 0; @@ -2558,7 +2573,11 @@ static void do_swap_thread() cb = can_break_param(scheme_current_thread); scheme_current_thread->can_break_at_swap = cb; } - scheme_gmp_tls_load(scheme_current_thread->gmp_tls); + { + GC_CAN_IGNORE void *data; + data = scheme_gmp_tls_load(scheme_current_thread->gmp_tls); + scheme_current_thread->gmp_tls_data = data; + } #ifdef RUNSTACK_IS_GLOBAL scheme_current_thread->runstack = MZ_RUNSTACK; scheme_current_thread->runstack_start = MZ_RUNSTACK_START; @@ -2782,7 +2801,8 @@ static void remove_thread(Scheme_Thread *r) thread_is_dead(r); /* In case we kill a thread while in a bignum operation: */ - scheme_gmp_tls_restore_snapshot(r->gmp_tls, NULL, ((r == scheme_current_thread) ? 1 : 2)); + scheme_gmp_tls_restore_snapshot(r->gmp_tls, r->gmp_tls_data, + NULL, ((r == scheme_current_thread) ? 1 : 2)); if (r == scheme_current_thread) { /* We're going to be swapped out immediately. */ @@ -2825,7 +2845,8 @@ static void start_child(Scheme_Thread * volatile child, MZ_CONT_MARK_STACK = scheme_current_thread->cont_mark_stack; MZ_CONT_MARK_POS = scheme_current_thread->cont_mark_pos; #endif - scheme_gmp_tls_unload(scheme_current_thread->gmp_tls); + scheme_gmp_tls_unload(scheme_current_thread->gmp_tls, scheme_current_thread->gmp_tls_data); + scheme_current_thread->gmp_tls_data = NULL; { Scheme_Object *l, *o; Scheme_Closure_Func f; @@ -2837,6 +2858,12 @@ static void start_child(Scheme_Thread * volatile child, } } + { + long cpm; + cpm = scheme_get_process_milliseconds(); + scheme_current_thread->current_start_process_msec = cpm; + } + RESETJMP(child); #if WATCH_FOR_NESTED_SWAPS @@ -3195,7 +3222,8 @@ static Scheme_Object *def_nested_exn_handler(int argc, Scheme_Object *argv[]) return scheme_void; /* misuse of exception handler (wrong kind of thread or under prompt) */ } -/* private, but declared as public to avoid inlining: */ +MZ_DO_NOT_INLINE(Scheme_Object *scheme_call_as_nested_thread(int argc, Scheme_Object *argv[], void *max_bottom)); + Scheme_Object *scheme_call_as_nested_thread(int argc, Scheme_Object *argv[], void *max_bottom) { Scheme_Thread *p = scheme_current_thread; @@ -3745,7 +3773,7 @@ static Scheme_Object *raise_user_break(int argc, Scheme_Object ** volatile argv) int cont; cont = SAME_OBJ((Scheme_Object *)scheme_jumping_to_continuation, argv[0]); - scheme_gmp_tls_restore_snapshot(scheme_current_thread->gmp_tls, save, !cont); + scheme_gmp_tls_restore_snapshot(scheme_current_thread->gmp_tls, NULL, save, !cont); scheme_longjmp(*savebuf, 1); } @@ -3764,6 +3792,11 @@ static void raise_break(Scheme_Thread *p) p->external_break = 0; + if (p->blocker && (p->block_check == (Scheme_Ready_Fun)syncing_ready)) { + /* Get out of lines for channels, etc., before calling a break exn handler. */ + scheme_post_syncing_nacks((Syncing *)p->blocker); + } + block_descriptor = p->block_descriptor; blocker = p->blocker; block_check = p->block_check; @@ -5669,7 +5702,7 @@ Scheme_Object *scheme_make_evt_set(int argc, Scheme_Object **argv) } void scheme_post_syncing_nacks(Syncing *syncing) - /* Also removes channel-syncers */ + /* Also removes channel-syncers. Can be called multiple times. */ { int i, c; Scheme_Object *l; @@ -5784,7 +5817,7 @@ static Scheme_Object *do_sync(const char *name, int argc, Scheme_Object *argv[], timeout = 0.0; /* means "no timeout" to block_until */ if (with_break) { - /* Suspended breaks when something is selected: */ + /* Suspended breaks when something is selected. */ syncing->disable_break = scheme_current_thread; } @@ -7325,6 +7358,12 @@ static void get_ready_for_GC() scheme_block_child_signals(1); #endif + { + GC_CAN_IGNORE void *data; + data = scheme_gmp_tls_load(scheme_current_thread->gmp_tls); + scheme_current_thread->gmp_tls_data = data; + } + did_gc_count++; } @@ -7332,6 +7371,9 @@ extern int GC_words_allocd; static void done_with_GC() { + scheme_gmp_tls_unload(scheme_current_thread->gmp_tls, scheme_current_thread->gmp_tls_data); + scheme_current_thread->gmp_tls_data = NULL; + #ifdef RUNSTACK_IS_GLOBAL # ifdef MZ_PRECISE_GC if (scheme_current_thread->running) { @@ -7505,6 +7547,45 @@ static Scheme_Object *current_stats(int argc, Scheme_Object *argv[]) return scheme_void; } +/*========================================================================*/ +/* gmp allocation */ +/*========================================================================*/ + +/* Allocate atomic, immobile memory for GMP. Although we have set up + GMP to reliably free anything that it allocates, we allocate via + the GC to get accounting with 3m. The set of allocated blocks are + stored in a "mem_pool" variable, which is a linked list; GMP + allocates with a stack discipline, so maintaining the list is easy. + Meanwhile, scheme_gmp_tls_unload, etc., attach to the pool to the + owning thread as needed for GC. */ + +void *scheme_malloc_gmp(unsigned long amt, void **mem_pool) +{ + void *p, *mp; + +#ifdef MZ_PRECISE_GC + if (amt < GC_malloc_stays_put_threshold()) + amt = GC_malloc_stays_put_threshold(); +#endif + + p = scheme_malloc_atomic(amt); + + mp = scheme_make_raw_pair(p, *mem_pool); + *mem_pool = mp; + + return p; +} + +void scheme_free_gmp(void *p, void **mem_pool) +{ + if (p != SCHEME_CAR(*mem_pool)) + scheme_log(NULL, + SCHEME_LOG_FATAL, + 0, + "bad GMP memory free"); + *mem_pool = SCHEME_CDR(*mem_pool); +} + /*========================================================================*/ /* precise GC */ /*========================================================================*/ diff --git a/src/worksp/mred/mred.manifest b/src/worksp/mred/mred.manifest index 06a169c986..d3142c851d 100644 --- a/src/worksp/mred/mred.manifest +++ b/src/worksp/mred/mred.manifest @@ -1,7 +1,7 @@ itemName, NULL, NULL, NULL); subMenu = menuItem->subMenu; subMenu->wxMacInsertSubmenu(); + ::InsertMenu(subMenu->cMacMenu, -1); hId = subMenu->cMacMenuId; } else { title = wxBuildMacMenuString(tempString, menuItem->itemName, &spc, &modifiers, &is_virt);